forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
monopam: add remote cache and improve status/sync
- Add remote_cache module for O(1) HEAD lookup with TTL expiry
- Rename git.ml to git_cli.ml for clarity
- Improve status command with fork analysis option
- Add tests for remote cache
- Various refactoring and improvements
+3937
-2380
+2
-1
bin/dune
+2
-1
bin/dune
+529
-311
bin/main.ml
+529
-311
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 run show_all () =
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 () =
91
147
Eio_main.run @@ fun env ->
92
148
with_config env @@ fun config ->
93
149
let fs = Eio.Stdenv.fs env in
94
150
let proc = Eio.Stdenv.process_mgr env in
95
151
match Monopam.status ~proc ~fs ~config () with
96
152
| Ok statuses ->
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
153
+
let sources = load_sources ~fs ~config in
105
154
Fmt.pr "%a" (Monopam.Status.pp_summary ?sources) statuses;
106
-
(* Check for unregistered opam files *)
107
155
(match Monopam.discover_packages ~fs ~config () with
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
156
+
| Ok pkgs -> print_unregistered ~fs ~config pkgs
137
157
| Error _ -> ());
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);
158
+
if show_forks then print_forks ~proc ~fs ~config ~show_all;
148
159
`Ok ()
149
160
| Error e ->
150
161
Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e;
151
162
`Error (false, "status failed")
152
163
in
153
-
Cmd.v info Term.(ret (const run $ all_arg $ logging_term))
164
+
Cmd.v info Term.(ret (const run $ all_arg $ forks_arg $ logging_term))
154
165
155
166
(* Sync command *)
156
167
···
226
237
in
227
238
let run package remote skip_push skip_pull () =
228
239
Eio_main.run @@ fun env ->
240
+
Eio.Switch.run @@ fun sw ->
229
241
with_config env @@ fun config ->
230
242
let fs = Eio.Stdenv.fs env in
231
243
let proc = Eio.Stdenv.process_mgr env in
244
+
let xdg = Xdge.create fs "monopam" in
232
245
match
233
-
Monopam.sync ~proc ~fs ~config ?package ~remote ~skip_push ~skip_pull ()
246
+
Monopam.sync ~sw ~env ~proc ~fs ~config ~xdg ?package ~remote ~skip_push
247
+
~skip_pull ()
234
248
with
235
249
| Ok summary ->
236
250
if summary.errors = [] then `Ok ()
···
447
461
[
448
462
`S Manpage.s_description;
449
463
`P
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.";
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.";
453
467
`S "WORKSPACE STRUCTURE";
454
468
`P
455
469
"The init command creates the following directory structure at the \
···
476
490
handle = \"yourname.bsky.social\"";
477
491
`S "HANDLE VALIDATION";
478
492
`P
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).";
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).";
482
495
`S "REGISTRY";
483
496
`P
484
497
"The registry is a git repository containing an opamverse.toml file \
···
589
602
[
590
603
`S Manpage.s_description;
591
604
`P
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.";
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.";
594
608
`P
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.";
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.";
598
612
`S "WHAT IT DOES";
599
613
`P "For the specified package:";
600
-
`I ("1.", "Looks up the package in <handle>'s opam-repo (verse/<handle>-opam/)");
614
+
`I
615
+
( "1.",
616
+
"Looks up the package in <handle>'s opam-repo (verse/<handle>-opam/)"
617
+
);
601
618
`I ("2.", "Finds all packages from the same git repository");
602
619
`I ("3.", "Creates entries in your opam-repo with your fork URL");
603
620
`P "After forking:";
604
-
`I ("1.", "Commit the new opam files: $(b,cd opam-repo && git add -A && git commit)");
621
+
`I
622
+
( "1.",
623
+
"Commit the new opam files: $(b,cd opam-repo && git add -A && git \
624
+
commit)" );
605
625
`I ("2.", "Run $(b,monopam sync) to pull the fork into your monorepo");
606
626
`S "PREREQUISITES";
607
627
`P "Before forking:";
608
-
`I ("-", "Run $(b,monopam verse pull <handle>) to sync the member's opam-repo");
628
+
`I
629
+
( "-",
630
+
"Run $(b,monopam verse pull <handle>) to sync the member's opam-repo"
631
+
);
609
632
`I ("-", "Create a fork of the repository on GitHub/GitLab/etc.");
610
633
`S Manpage.s_examples;
611
634
`P "Fork a package from a verse member:";
612
-
`Pre "monopam fork http2 --from sadiq.bsky.social --url git@github.com:me/http2.git";
635
+
`Pre
636
+
"monopam fork http2 --from sadiq.bsky.social --url \
637
+
git@github.com:me/http2.git";
613
638
`P "Preview what would be forked (multi-package repos):";
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";
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";
621
648
`P "After forking, commit and sync:";
622
-
`Pre "cd opam-repo && git add -A && git commit -m \"Fork cohttp\"\n\
623
-
monopam sync";
649
+
`Pre
650
+
"cd opam-repo && git add -A && git commit -m \"Fork cohttp\"\n\
651
+
monopam sync";
624
652
`S "ERRORS";
625
653
`P
626
-
"The command will fail if any package from the source repo already exists \
627
-
in your opam-repo. Remove conflicting packages first with:";
654
+
"The command will fail if any package from the source repo already \
655
+
exists in your opam-repo. Remove conflicting packages first with:";
628
656
`Pre "rm -rf opam-repo/packages/<package-name>";
629
657
]
630
658
in
···
635
663
in
636
664
let from_arg =
637
665
let doc = "Verse member handle to fork from (e.g., 'avsm.bsky.social')" in
638
-
Arg.(required & opt (some string) None & info [ "from" ] ~docv:"HANDLE" ~doc)
666
+
Arg.(
667
+
required & opt (some string) None & info [ "from" ] ~docv:"HANDLE" ~doc)
639
668
in
640
669
let url_arg =
641
670
let doc = "Git URL of your fork (e.g., 'git@github.com:you/repo.git')" in
···
650
679
with_verse_config env @@ fun config ->
651
680
let fs = Eio.Stdenv.fs env in
652
681
let proc = Eio.Stdenv.process_mgr env in
653
-
match Monopam.Verse.fork ~proc ~fs ~config ~handle ~package ~fork_url ~dry_run () with
682
+
match
683
+
Monopam.Verse.fork ~proc ~fs ~config ~handle ~package ~fork_url ~dry_run
684
+
()
685
+
with
654
686
| Ok result ->
655
687
if dry_run then begin
656
688
Fmt.pr "Would fork %d package(s) from %s:@."
657
-
(List.length result.packages_forked) result.source_handle;
689
+
(List.length result.packages_forked)
690
+
result.source_handle;
658
691
List.iter (fun p -> Fmt.pr " %s@." p) result.packages_forked
659
-
end else begin
692
+
end
693
+
else begin
660
694
(* Update sources.toml with fork information *)
661
695
let mono_path = Monopam.Verse_config.mono_path config in
662
696
let sources_path = Fpath.(mono_path / "sources.toml") in
663
697
let sources =
664
-
match Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
698
+
match
699
+
Monopam.Sources_registry.load
700
+
~fs:(fs :> _ Eio.Path.t)
701
+
sources_path
702
+
with
665
703
| Ok s -> s
666
704
| Error _ -> Monopam.Sources_registry.empty
667
705
in
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
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
677
726
| Ok () ->
678
-
Fmt.pr "Updated sources.toml with fork entry for %s@." result.subtree_name
727
+
Fmt.pr "Updated sources.toml with fork entry for %s@."
728
+
result.subtree_name
679
729
| Error msg ->
680
730
Fmt.epr "Warning: Failed to update sources.toml: %s@." msg);
681
731
Fmt.pr "Forked %d package(s): %a@."
682
732
(List.length result.packages_forked)
683
-
Fmt.(list ~sep:(any ", ") string) result.packages_forked;
733
+
Fmt.(list ~sep:(any ", ") string)
734
+
result.packages_forked;
684
735
Fmt.pr "@.Next steps:@.";
685
-
Fmt.pr " 1. cd opam-repo && git add -A && git commit -m \"Fork ...\"@.";
736
+
Fmt.pr
737
+
" 1. cd opam-repo && git add -A && git commit -m \"Fork ...\"@.";
686
738
Fmt.pr " 2. monopam sync@."
687
739
end;
688
740
`Ok ()
···
690
742
Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e;
691
743
`Error (false, "fork failed")
692
744
in
693
-
Cmd.v info Term.(ret (const run $ package_arg $ from_arg $ url_arg $ dry_run_arg $ logging_term))
745
+
Cmd.v info
746
+
Term.(
747
+
ret
748
+
(const run $ package_arg $ from_arg $ url_arg $ dry_run_arg
749
+
$ logging_term))
694
750
695
751
let verse_cmd =
696
752
let doc = "Verse member operations" in
···
699
755
`S Manpage.s_description;
700
756
`P
701
757
"Commands for working with verse community members. The verse system \
702
-
enables federated collaboration across multiple developers' monorepos.";
758
+
enables federated collaboration across multiple developers' \
759
+
monorepos.";
703
760
`P
704
761
"Members are identified by handles - typically domain names like \
705
762
'yourname.bsky.social' or 'your-domain.com'.";
706
763
`S "NOTE";
707
764
`P
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.";
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.";
711
768
`S "COMMANDS";
712
769
`I ("members", "List all members in the community registry");
713
-
`I ("fork <pkg> --from <handle> --url <url>", "Fork a package from a verse member");
770
+
`I
771
+
( "fork <pkg> --from <handle> --url <url>",
772
+
"Fork a package from a verse member" );
714
773
`S Manpage.s_examples;
715
774
`P "List all community members:";
716
775
`Pre "monopam verse members";
717
776
`P "Fork a package from another member:";
718
-
`Pre "monopam verse fork cohttp --from avsm.bsky.social --url git@github.com:me/cohttp.git";
777
+
`Pre
778
+
"monopam verse fork cohttp --from avsm.bsky.social --url \
779
+
git@github.com:me/cohttp.git";
719
780
]
720
781
in
721
782
let info = Cmd.info "verse" ~doc ~man in
722
-
Cmd.group info
723
-
[
724
-
verse_members_cmd;
725
-
verse_fork_cmd;
726
-
]
783
+
Cmd.group info [ verse_members_cmd; verse_fork_cmd ]
727
784
728
785
(* Diff command *)
729
786
···
733
790
[
734
791
`S Manpage.s_description;
735
792
`P
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.";
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.";
739
796
`S "OUTPUT";
740
-
`P "First shows the verse status summary, then for each repository where \
741
-
a verse member is ahead:";
797
+
`P
798
+
"First shows the verse status summary, then for each repository where \
799
+
a verse member is ahead:";
742
800
`I ("Repository name", "With the handle and relationship");
743
801
`I ("Commits", "List of commits they have that you don't (max 20)");
744
802
`S "RELATIONSHIPS";
745
803
`I ("+N", "They have N commits you don't have");
746
804
`I ("+N/-M", "Diverged: they have N new commits, you have M new commits");
747
805
`S "CACHING";
748
-
`P "Remote fetches are cached for 1 hour to improve performance. \
749
-
Use $(b,--refresh) to force fresh fetches from all remotes.";
806
+
`P
807
+
"Remote fetches are cached for 1 hour to improve performance. Use \
808
+
$(b,--refresh) to force fresh fetches from all remotes.";
750
809
`S Manpage.s_examples;
751
810
`P "Show diffs for all repos needing attention (uses cache):";
752
811
`Pre "monopam diff";
···
762
821
in
763
822
let info = Cmd.info "diff" ~doc ~man in
764
823
let arg =
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
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
768
829
Arg.(value & pos 0 (some string) None & info [] ~docv:"REPO|SHA" ~doc)
769
830
in
770
831
let refresh_arg =
771
-
let doc = "Force fresh fetches from all remotes, ignoring the 1-hour cache." in
832
+
let doc =
833
+
"Force fresh fetches from all remotes, ignoring the 1-hour cache."
834
+
in
772
835
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
773
836
in
774
837
let patch_arg =
···
783
846
let proc = Eio.Stdenv.process_mgr env in
784
847
(* Check if arg looks like a commit SHA *)
785
848
match arg with
786
-
| Some sha when Monopam.is_commit_sha sha ->
849
+
| Some sha when Monopam.is_commit_sha sha -> (
787
850
(* Show patch for specific commit *)
788
-
(match Monopam.diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh () with
851
+
match
852
+
Monopam.diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh
853
+
()
854
+
with
789
855
| Some info ->
790
-
let short_hash = String.sub info.commit_hash 0 (min 7 (String.length info.commit_hash)) in
856
+
let short_hash =
857
+
String.sub info.commit_hash 0
858
+
(min 7 (String.length info.commit_hash))
859
+
in
791
860
Fmt.pr "%a %s (%s/%s)@.@.%s@."
792
-
Fmt.(styled `Yellow string) short_hash
793
-
info.commit_subject
794
-
info.commit_repo info.commit_handle
861
+
Fmt.(styled `Yellow string)
862
+
short_hash info.commit_subject info.commit_repo info.commit_handle
795
863
info.commit_patch;
796
864
`Ok ()
797
865
| None ->
798
866
Fmt.epr "Commit %s not found in any verse diff@." sha;
799
867
`Error (false, "commit not found"))
800
868
| repo ->
801
-
let result = Monopam.diff ~proc ~fs ~config ~verse_config ?repo ~refresh ~patch () in
869
+
let result =
870
+
Monopam.diff ~proc ~fs ~config ~verse_config ?repo ~refresh ~patch ()
871
+
in
802
872
Fmt.pr "%a" (Monopam.pp_diff_result ~show_patch:patch) result;
803
873
`Ok ()
804
874
in
805
-
Cmd.v info Term.(ret (const run $ arg $ refresh_arg $ patch_arg $ logging_term))
875
+
Cmd.v info
876
+
Term.(ret (const run $ arg $ refresh_arg $ patch_arg $ logging_term))
806
877
807
878
(* Pull command - pull from verse members *)
808
879
···
822
893
`I ("3.", "$(b,monopam sync) - Sync changes into your monorepo");
823
894
`S "MERGING BEHAVIOR";
824
895
`P "When you're behind (they have commits you don't):";
825
-
`I ("Fast-forward", "If your branch has no new commits, a fast-forward merge is used.");
896
+
`I
897
+
( "Fast-forward",
898
+
"If your branch has no new commits, a fast-forward merge is used." );
826
899
`P "When branches have diverged (both have new commits):";
827
900
`I ("Merge commit", "A merge commit is created to combine the histories.");
828
901
`S Manpage.s_examples;
···
836
909
in
837
910
let info = Cmd.info "pull" ~doc ~man in
838
911
let handle_arg =
839
-
let doc = "The verse member handle to pull from (e.g., avsm.bsky.social)." in
912
+
let doc =
913
+
"The verse member handle to pull from (e.g., avsm.bsky.social)."
914
+
in
840
915
Arg.(required & pos 0 (some string) None & info [] ~docv:"HANDLE" ~doc)
841
916
in
842
917
let repo_arg =
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
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
845
922
Arg.(value & pos 1 (some string) None & info [] ~docv:"REPO" ~doc)
846
923
in
847
924
let refresh_arg =
848
-
let doc = "Force fresh fetches from all remotes, ignoring the 1-hour cache." in
925
+
let doc =
926
+
"Force fresh fetches from all remotes, ignoring the 1-hour cache."
927
+
in
849
928
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
850
929
in
851
930
let run handle repo refresh () =
···
854
933
with_verse_config env @@ fun verse_config ->
855
934
let fs = Eio.Stdenv.fs env in
856
935
let proc = Eio.Stdenv.process_mgr env in
857
-
match Monopam.pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo ~refresh () with
936
+
match
937
+
Monopam.pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo
938
+
~refresh ()
939
+
with
858
940
| Ok result ->
859
941
Fmt.pr "%a" Monopam.pp_handle_pull_result result;
860
942
if result.repos_failed <> [] then
···
864
946
`Ok ()
865
947
end
866
948
else begin
867
-
Fmt.pr "@.Run $(b,monopam sync) to merge changes into your monorepo.@.";
949
+
Fmt.pr
950
+
"@.Run $(b,monopam sync) to merge changes into your monorepo.@.";
868
951
`Ok ()
869
952
end
870
953
| Error e ->
871
954
Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e;
872
955
`Error (false, "pull failed")
873
956
in
874
-
Cmd.v info Term.(ret (const run $ handle_arg $ repo_arg $ refresh_arg $ logging_term))
957
+
Cmd.v info
958
+
Term.(ret (const run $ handle_arg $ repo_arg $ refresh_arg $ logging_term))
875
959
876
960
(* Cherrypick command *)
877
961
···
881
965
[
882
966
`S Manpage.s_description;
883
967
`P
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.";
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.";
886
971
`S "WORKFLOW";
887
972
`P "The typical workflow for cherry-picking specific commits:";
888
973
`I ("1.", "$(b,monopam diff) - See available commits with their hashes");
···
899
984
in
900
985
let info = Cmd.info "cherrypick" ~doc ~man in
901
986
let sha_arg =
902
-
let doc = "The commit SHA (or prefix) to cherry-pick. Must be at least 7 characters." in
987
+
let doc =
988
+
"The commit SHA (or prefix) to cherry-pick. Must be at least 7 \
989
+
characters."
990
+
in
903
991
Arg.(required & pos 0 (some string) None & info [] ~docv:"SHA" ~doc)
904
992
in
905
993
let refresh_arg =
906
-
let doc = "Force fresh fetches from all remotes, ignoring the 1-hour cache." in
994
+
let doc =
995
+
"Force fresh fetches from all remotes, ignoring the 1-hour cache."
996
+
in
907
997
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
908
998
in
909
999
let run sha refresh () =
···
912
1002
with_verse_config env @@ fun verse_config ->
913
1003
let fs = Eio.Stdenv.fs env in
914
1004
let proc = Eio.Stdenv.process_mgr env in
915
-
match Monopam.cherrypick ~proc ~fs ~config ~verse_config ~sha ~refresh () with
1005
+
match
1006
+
Monopam.cherrypick ~proc ~fs ~config ~verse_config ~sha ~refresh ()
1007
+
with
916
1008
| Ok result ->
917
1009
Fmt.pr "%a" Monopam.pp_cherrypick_result result;
918
1010
Fmt.pr "Run $(b,monopam sync) to merge changes into your monorepo.@.";
···
982
1074
in
983
1075
let quiet_arg =
984
1076
let doc =
985
-
"Quiet mode for cron jobs. Only output if issues are found. \
986
-
Exit code reflects health status (0=healthy, 1=warning, 2=critical)."
1077
+
"Quiet mode for cron jobs. Only output if issues are found. Exit code \
1078
+
reflects health status (0=healthy, 1=warning, 2=critical)."
987
1079
in
988
1080
Arg.(value & flag & info [ "quiet"; "q" ] ~doc)
989
1081
in
990
1082
let run package json no_sync quiet () =
991
1083
Eio_main.run @@ fun env ->
1084
+
Eio.Switch.run @@ fun sw ->
992
1085
with_config env @@ fun config ->
993
1086
with_verse_config env @@ fun verse_config ->
994
1087
let fs = Eio.Stdenv.fs env in
995
1088
let proc = Eio.Stdenv.process_mgr env in
996
1089
let clock = Eio.Stdenv.clock env in
1090
+
let xdg = Xdge.create fs "monopam" in
997
1091
(* Run sync before analysis unless --no-sync is specified *)
998
-
if not no_sync && not quiet then begin
1092
+
if (not no_sync) && not quiet then begin
999
1093
Fmt.pr "Syncing workspace before analysis...@.";
1000
-
match Monopam.sync ~proc ~fs ~config ?package () with
1094
+
match Monopam.sync ~sw ~env ~proc ~fs ~config ~xdg ?package () with
1001
1095
| Ok _summary -> ()
1002
1096
| Error e ->
1003
1097
Fmt.pr "Warning: sync failed: %a@." Monopam.pp_error_with_hint e;
···
1005
1099
end
1006
1100
else if not no_sync then begin
1007
1101
(* Quiet mode but still sync - just don't print progress *)
1008
-
let _ = Monopam.sync ~proc ~fs ~config ?package () in ()
1102
+
let _ = Monopam.sync ~sw ~env ~proc ~fs ~config ~xdg ?package () in
1103
+
()
1009
1104
end;
1010
1105
let report =
1011
1106
Monopam.Doctor.analyze ~proc ~fs ~config ~verse_config ~clock ?package
···
1029
1124
end
1030
1125
in
1031
1126
Cmd.v info
1032
-
Term.(ret (const run $ package_arg $ json_arg $ no_sync_arg $ quiet_arg $ logging_term))
1127
+
Term.(
1128
+
ret
1129
+
(const run $ package_arg $ json_arg $ no_sync_arg $ quiet_arg
1130
+
$ logging_term))
1033
1131
1034
1132
(* Feature commands *)
1035
1133
···
1043
1141
[
1044
1142
`S Manpage.s_description;
1045
1143
`P
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.";
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.";
1049
1148
`S "HOW IT WORKS";
1050
1149
`P "The command:";
1051
1150
`I ("1.", "Creates the $(b,work/) directory if it doesn't exist");
···
1053
1152
`I ("3.", "Checks out a new branch named $(b,<name>)");
1054
1153
`S Manpage.s_examples;
1055
1154
`P "Create a feature worktree:";
1056
-
`Pre "monopam feature add my-feature\n\
1057
-
cd work/my-feature\n\
1058
-
# Now you can work here independently";
1155
+
`Pre
1156
+
"monopam feature add my-feature\n\
1157
+
cd work/my-feature\n\
1158
+
# Now you can work here independently";
1059
1159
`P "Have multiple Claudes work in parallel:";
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";
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";
1066
1167
]
1067
1168
in
1068
1169
let info = Cmd.info "add" ~doc ~man in
···
1073
1174
let proc = Eio.Stdenv.process_mgr env in
1074
1175
match Monopam.Feature.add ~proc ~fs ~config:verse_config ~name () with
1075
1176
| Ok entry ->
1076
-
Fmt.pr "Created feature worktree '%s' at %a@." entry.name Fpath.pp entry.path;
1177
+
Fmt.pr "Created feature worktree '%s' at %a@." entry.name Fpath.pp
1178
+
entry.path;
1077
1179
Fmt.pr "@.To start working:@.";
1078
1180
Fmt.pr " cd %a@." Fpath.pp entry.path;
1079
1181
`Ok ()
···
1110
1212
with_verse_config env @@ fun verse_config ->
1111
1213
let fs = Eio.Stdenv.fs env in
1112
1214
let proc = Eio.Stdenv.process_mgr env in
1113
-
match Monopam.Feature.remove ~proc ~fs ~config:verse_config ~name ~force () with
1215
+
match
1216
+
Monopam.Feature.remove ~proc ~fs ~config:verse_config ~name ~force ()
1217
+
with
1114
1218
| Ok () ->
1115
1219
Fmt.pr "Removed feature worktree '%s'.@." name;
1116
1220
`Ok ()
···
1118
1222
Fmt.epr "Error: %a@." Monopam.Feature.pp_error_with_hint e;
1119
1223
`Error (false, "feature remove failed")
1120
1224
in
1121
-
Cmd.v info Term.(ret (const run $ feature_name_arg $ force_arg $ logging_term))
1225
+
Cmd.v info
1226
+
Term.(ret (const run $ feature_name_arg $ force_arg $ logging_term))
1122
1227
1123
1228
let feature_list_cmd =
1124
1229
let doc = "List all feature worktrees" in
···
1137
1242
let fs = Eio.Stdenv.fs env in
1138
1243
let proc = Eio.Stdenv.process_mgr env in
1139
1244
let entries = Monopam.Feature.list ~proc ~fs ~config:verse_config () in
1140
-
if entries = [] then
1141
-
Fmt.pr "No feature worktrees found.@."
1245
+
if entries = [] then Fmt.pr "No feature worktrees found.@."
1142
1246
else begin
1143
1247
Fmt.pr "Feature worktrees:@.";
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
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
1150
1253
end;
1151
1254
`Ok ()
1152
1255
in
···
1163
1266
working on different features simultaneously.";
1164
1267
`S "WORKSPACE STRUCTURE";
1165
1268
`P "Feature worktrees are created in the $(b,work/) directory:";
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
-
└── ...";
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
+
└── ...";
1172
1276
`S "COMMANDS";
1173
1277
`I ("add <name>", "Create a new feature worktree");
1174
1278
`I ("remove <name>", "Remove a feature worktree");
1175
1279
`I ("list", "List all feature worktrees");
1176
1280
`S "WORKFLOW";
1177
1281
`P "Typical workflow for parallel development:";
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";
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";
1191
1296
]
1192
1297
in
1193
1298
let info = Cmd.info "feature" ~doc ~man in
···
1209
1314
.devcontainer configuration, it will be created automatically.";
1210
1315
`P
1211
1316
"This is the recommended way to get started with monopam. The \
1212
-
devcontainer provides a consistent environment with OCaml, opam, \
1213
-
and all required tools pre-installed.";
1317
+
devcontainer provides a consistent environment with OCaml, opam, and \
1318
+
all required tools pre-installed.";
1214
1319
`S "WHAT IT DOES";
1215
1320
`P "For a new directory (no .devcontainer/):";
1216
1321
`I ("1.", "Creates the target directory if needed");
···
1222
1327
`I ("1.", "Starts the devcontainer if not running");
1223
1328
`I ("2.", "Opens an interactive shell inside the container");
1224
1329
`S Manpage.s_options;
1225
-
`P "Use $(b,--url) to specify a custom devcontainer.json URL if you want \
1226
-
to use a different base configuration.";
1330
+
`P
1331
+
"Use $(b,--url) to specify a custom devcontainer.json URL if you want \
1332
+
to use a different base configuration.";
1227
1333
`S Manpage.s_examples;
1228
1334
`P "Create a new devcontainer workspace:";
1229
1335
`Pre "monopam devcontainer ~/my-ocaml-project";
1230
1336
`P "Enter an existing devcontainer:";
1231
1337
`Pre "monopam devcontainer ~/my-ocaml-project";
1232
1338
`P "Use a custom devcontainer.json:";
1233
-
`Pre "monopam devcontainer --url https://example.com/devcontainer.json ~/project";
1339
+
`Pre
1340
+
"monopam devcontainer --url https://example.com/devcontainer.json \
1341
+
~/project";
1234
1342
]
1235
1343
in
1236
1344
let info = Cmd.info "devcontainer" ~doc ~man in
···
1239
1347
Arg.(required & pos 0 (some string) None & info [] ~docv:"PATH" ~doc)
1240
1348
in
1241
1349
let url_arg =
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)
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)
1244
1358
in
1245
1359
let run path url () =
1246
1360
(* Resolve to absolute path *)
1247
1361
let abs_path =
1248
-
if Filename.is_relative path then
1249
-
Filename.concat (Sys.getcwd ()) path
1362
+
if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path
1250
1363
else path
1251
1364
in
1252
1365
let devcontainer_dir = Filename.concat abs_path ".devcontainer" in
1253
-
let devcontainer_json = Filename.concat devcontainer_dir "devcontainer.json" in
1366
+
let devcontainer_json =
1367
+
Filename.concat devcontainer_dir "devcontainer.json"
1368
+
in
1254
1369
(* Check if .devcontainer exists *)
1255
-
let needs_init = not (Sys.file_exists devcontainer_dir && Sys.is_directory devcontainer_dir) in
1370
+
let needs_init =
1371
+
not (Sys.file_exists devcontainer_dir && Sys.is_directory devcontainer_dir)
1372
+
in
1256
1373
if needs_init then begin
1257
1374
Fmt.pr "Initializing devcontainer in %s...@." abs_path;
1258
1375
(* Create directories *)
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, _, _) -> ());
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, _, _) -> ());
1261
1380
(* Fetch devcontainer.json using curl *)
1262
1381
Fmt.pr "Fetching devcontainer.json from %s...@." url;
1263
-
let curl_cmd = Printf.sprintf "curl -fsSL '%s' -o '%s'" url devcontainer_json in
1382
+
let curl_cmd =
1383
+
Printf.sprintf "curl -fsSL '%s' -o '%s'" url devcontainer_json
1384
+
in
1264
1385
let ret = Sys.command curl_cmd in
1265
1386
if ret <> 0 then begin
1266
-
Fmt.epr "Error: Failed to fetch devcontainer.json (curl exit code %d)@." ret;
1387
+
Fmt.epr "Error: Failed to fetch devcontainer.json (curl exit code %d)@."
1388
+
ret;
1267
1389
exit 1
1268
1390
end;
1269
1391
Fmt.pr "Created %s@." devcontainer_json;
1270
1392
(* Build and start the devcontainer *)
1271
1393
Fmt.pr "Building devcontainer (this may take a while on first run)...@.";
1272
-
let up_cmd = Printf.sprintf "npx @devcontainers/cli up --workspace-folder '%s' --remove-existing-container" abs_path in
1394
+
let up_cmd =
1395
+
Printf.sprintf
1396
+
"npx @devcontainers/cli up --workspace-folder '%s' \
1397
+
--remove-existing-container"
1398
+
abs_path
1399
+
in
1273
1400
let ret = Sys.command up_cmd in
1274
1401
if ret <> 0 then begin
1275
1402
Fmt.epr "Error: Failed to start devcontainer (exit code %d)@." ret;
···
1278
1405
end;
1279
1406
(* Exec into the devcontainer *)
1280
1407
Fmt.pr "Entering devcontainer...@.";
1281
-
let exec_cmd = Printf.sprintf "npx @devcontainers/cli exec --workspace-folder '%s' bash -l" abs_path in
1408
+
let exec_cmd =
1409
+
Printf.sprintf
1410
+
"npx @devcontainers/cli exec --workspace-folder '%s' bash -l" abs_path
1411
+
in
1282
1412
let ret = Sys.command exec_cmd in
1283
1413
if ret <> 0 then
1284
1414
`Error (false, Printf.sprintf "devcontainer exec failed with code %d" ret)
1285
-
else
1286
-
`Ok ()
1415
+
else `Ok ()
1287
1416
in
1288
1417
Cmd.v info Term.(ret (const run $ path_arg $ url_arg $ logging_term))
1289
1418
···
1316
1445
with the extracted history, then re-adds mono/<name>/ as a subtree.";
1317
1446
`S "FORK MODES";
1318
1447
`P "The fork command handles two scenarios:";
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.");
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." );
1325
1458
`S "WHAT IT DOES";
1326
1459
`P "The fork command performs a complete workflow in one step:";
1327
1460
`I ("1.", "Analyzes mono/<name>/ to detect fork mode");
1328
1461
`I ("2.", "Builds an action plan and shows discovery details");
1329
1462
`I ("3.", "Prompts for confirmation (use $(b,--yes) to skip)");
1330
1463
`I ("4.", "Creates a new git repo at src/<name>/");
1331
-
`I ("5.", "Extracts history (subtree split) or copies files (fresh package)");
1464
+
`I
1465
+
( "5.",
1466
+
"Extracts history (subtree split) or copies files (fresh package)" );
1332
1467
`I ("6.", "Removes mono/<name>/ from git and commits");
1333
1468
`I ("7.", "Re-adds mono/<name>/ as a proper subtree from src/<name>/");
1334
1469
`I ("8.", "Updates sources.toml with $(b,origin = \"fork\")");
···
1381
1516
let mono_path = Monopam.Config.mono_path config in
1382
1517
let subtree_path = Fpath.(mono_path / name) in
1383
1518
let knot = Monopam.Config.knot config in
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 *)
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 *)
1387
1524
else begin
1388
1525
match suggested with
1389
-
| Some default_url ->
1526
+
| Some default_url -> (
1390
1527
Fmt.pr "Remote push URL [%s]: %!" default_url;
1391
-
(match prompt_string "" with
1392
-
| None -> Some default_url (* User pressed enter, use default *)
1393
-
| Some entered -> Some entered)
1528
+
match prompt_string "" with
1529
+
| None -> Some default_url (* User pressed enter, use default *)
1530
+
| Some entered -> Some entered)
1394
1531
| None ->
1395
1532
Fmt.pr "Remote push URL (leave empty to skip): %!";
1396
1533
prompt_string ""
1397
1534
end
1398
1535
in
1399
1536
(* Build the plan *)
1400
-
match Monopam.Fork_join.plan_fork ~proc ~fs ~config ~name ?push_url:url ~dry_run () with
1537
+
match
1538
+
Monopam.Fork_join.plan_fork ~proc ~fs ~config ~name ?push_url:url ~dry_run
1539
+
()
1540
+
with
1401
1541
| Error e ->
1402
1542
Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e;
1403
1543
`Error (false, "fork failed")
···
1405
1545
(* Print discovery and actions *)
1406
1546
Fmt.pr "Analyzing fork request for '%s'...@.@." name;
1407
1547
Fmt.pr "Discovery:@.%a@." Monopam.Fork_join.pp_discovery plan.discovery;
1408
-
(match url with
1409
-
| Some u -> Fmt.pr " Remote URL: %s@." u
1410
-
| None -> ());
1548
+
(match url with Some u -> Fmt.pr " Remote URL: %s@." u | None -> ());
1411
1549
Fmt.pr "@.Actions to perform:@.";
1412
-
List.iteri (fun i action ->
1413
-
Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action
1414
-
) plan.actions;
1550
+
List.iteri
1551
+
(fun i action ->
1552
+
Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action)
1553
+
plan.actions;
1415
1554
Fmt.pr "@.";
1416
1555
(* Prompt for confirmation unless --yes or --dry-run *)
1417
1556
let proceed =
1418
1557
if dry_run then begin
1419
1558
Fmt.pr "(dry-run mode - no changes will be made)@.";
1420
1559
true
1421
-
end else if yes then
1422
-
true
1423
-
else
1424
-
confirm "Proceed?"
1560
+
end
1561
+
else if yes then true
1562
+
else confirm "Proceed?"
1425
1563
in
1426
1564
if not proceed then begin
1427
1565
Fmt.pr "Cancelled.@.";
1428
1566
`Ok ()
1429
-
end else begin
1567
+
end
1568
+
else begin
1430
1569
(* Execute the plan *)
1431
1570
match Monopam.Fork_join.execute_fork_plan ~proc ~fs plan with
1432
1571
| Ok result ->
···
1435
1574
Fmt.pr "@.Next steps:@.";
1436
1575
Fmt.pr " 1. Review the new repo: cd src/%s@." result.name;
1437
1576
match url with
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>@."
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>@."
1440
1581
end;
1441
1582
`Ok ()
1442
1583
| Error e ->
···
1444
1585
`Error (false, "fork failed")
1445
1586
end
1446
1587
in
1447
-
Cmd.v info Term.(ret (const run $ name_arg $ url_arg $ dry_run_arg $ yes_arg $ logging_term))
1588
+
Cmd.v info
1589
+
Term.(
1590
+
ret (const run $ name_arg $ url_arg $ dry_run_arg $ yes_arg $ logging_term))
1448
1591
1449
1592
(* Join command *)
1450
1593
···
1459
1602
`S "JOIN MODES";
1460
1603
`P "The join command handles multiple scenarios:";
1461
1604
`I ("URL join", "Clone from a git URL and add as subtree (default).");
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).");
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)." );
1465
1612
`S "WHAT IT DOES";
1466
1613
`P "The join command:";
1467
1614
`I ("1.", "Analyzes the source (URL or local path)");
···
1472
1619
`I ("6.", "Updates sources.toml with $(b,origin = \"join\")");
1473
1620
`S "JOINING FROM VERSE";
1474
1621
`P "To join a package from a verse member, use $(b,--from):";
1475
-
`Pre "monopam join --from avsm.bsky.social --url git@github.com:me/cohttp.git cohttp";
1622
+
`Pre
1623
+
"monopam join --from avsm.bsky.social --url \
1624
+
git@github.com:me/cohttp.git cohttp";
1476
1625
`P "This will:";
1477
1626
`I ("-", "Look up the package in their opam-repo");
1478
1627
`I ("-", "Find all packages from the same git repository");
···
1493
1642
`P "Join with a custom name using --as:";
1494
1643
`Pre "monopam join https://github.com/someone/some-lib --as my-lib";
1495
1644
`P "Join with upstream tracking (for forks):";
1496
-
`Pre "monopam join https://github.com/me/cohttp --upstream https://github.com/mirage/cohttp";
1645
+
`Pre
1646
+
"monopam join https://github.com/me/cohttp --upstream \
1647
+
https://github.com/mirage/cohttp";
1497
1648
`P "Join from a verse member:";
1498
-
`Pre "monopam join cohttp --from avsm.bsky.social --url git@github.com:me/cohttp.git";
1649
+
`Pre
1650
+
"monopam join cohttp --from avsm.bsky.social --url \
1651
+
git@github.com:me/cohttp.git";
1499
1652
`P "Preview what would be done:";
1500
1653
`Pre "monopam join https://github.com/someone/lib --dry-run";
1501
1654
`P "Join without confirmation:";
···
1537
1690
let fs = Eio.Stdenv.fs env in
1538
1691
let proc = Eio.Stdenv.process_mgr env in
1539
1692
match from with
1540
-
| Some handle ->
1693
+
| Some handle -> (
1541
1694
(* Join from verse member - requires --url for your fork *)
1542
1695
(* Uses legacy API as it involves verse-specific operations *)
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 ->
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 -> (
1567
1731
(* Normal join from URL or local path - use plan-based workflow *)
1568
1732
let source = match fork_url with Some u -> u | None -> url_or_pkg in
1569
-
let name = match fork_url with Some _ -> Some url_or_pkg | None -> as_name in
1733
+
let name =
1734
+
match fork_url with Some _ -> Some url_or_pkg | None -> as_name
1735
+
in
1570
1736
(* Build the plan *)
1571
-
match Monopam.Fork_join.plan_join ~proc ~fs ~config ~source ?name ?upstream ~dry_run () with
1737
+
match
1738
+
Monopam.Fork_join.plan_join ~proc ~fs ~config ~source ?name ?upstream
1739
+
~dry_run ()
1740
+
with
1572
1741
| Error e ->
1573
1742
Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e;
1574
1743
`Error (false, "join failed")
···
1581
1750
(if is_local then "local directory" else "remote URL");
1582
1751
Fmt.pr "%a" Monopam.Fork_join.pp_discovery plan.discovery;
1583
1752
Fmt.pr "@.Actions to perform:@.";
1584
-
List.iteri (fun i action ->
1585
-
Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action
1586
-
) plan.actions;
1753
+
List.iteri
1754
+
(fun i action ->
1755
+
Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action)
1756
+
plan.actions;
1587
1757
Fmt.pr "@.";
1588
1758
(* Prompt for confirmation unless --yes or --dry-run *)
1589
1759
let proceed =
1590
1760
if dry_run then begin
1591
1761
Fmt.pr "(dry-run mode - no changes will be made)@.";
1592
1762
true
1593
-
end else if yes then
1594
-
true
1595
-
else
1596
-
confirm "Proceed?"
1763
+
end
1764
+
else if yes then true
1765
+
else confirm "Proceed?"
1597
1766
in
1598
1767
if not proceed then begin
1599
1768
Fmt.pr "Cancelled.@.";
1600
1769
`Ok ()
1601
-
end else begin
1770
+
end
1771
+
else begin
1602
1772
(* Execute the plan *)
1603
1773
match Monopam.Fork_join.execute_join_plan ~proc ~fs plan with
1604
1774
| Ok result ->
···
1611
1781
| Error e ->
1612
1782
Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e;
1613
1783
`Error (false, "join failed")
1614
-
end
1784
+
end)
1615
1785
in
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))
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))
1617
1791
1618
1792
(* Rejoin command *)
1619
1793
···
1641
1815
`I ("1.", "Verifies src/<name>/ exists and is a git repo");
1642
1816
`I ("2.", "Verifies mono/<name>/ does not exist");
1643
1817
`I ("3.", "Prompts for confirmation (use $(b,--yes) to skip)");
1644
-
`I ("4.", "Uses $(b,git subtree add) to bring src/<name>/ into mono/<name>/");
1818
+
`I
1819
+
( "4.",
1820
+
"Uses $(b,git subtree add) to bring src/<name>/ into mono/<name>/" );
1645
1821
`S Manpage.s_examples;
1646
1822
`P "Re-add a package from src/:";
1647
1823
`Pre "monopam rejoin my-lib";
···
1679
1855
Fmt.pr "Analyzing rejoin request for '%s'...@.@." name;
1680
1856
Fmt.pr "Discovery:@.%a@." Monopam.Fork_join.pp_discovery plan.discovery;
1681
1857
Fmt.pr "@.Actions to perform:@.";
1682
-
List.iteri (fun i action ->
1683
-
Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action
1684
-
) plan.actions;
1858
+
List.iteri
1859
+
(fun i action ->
1860
+
Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action)
1861
+
plan.actions;
1685
1862
Fmt.pr "@.";
1686
1863
(* Prompt for confirmation unless --yes or --dry-run *)
1687
1864
let proceed =
1688
1865
if dry_run then begin
1689
1866
Fmt.pr "(dry-run mode - no changes will be made)@.";
1690
1867
true
1691
-
end else if yes then
1692
-
true
1693
-
else
1694
-
confirm "Proceed?"
1868
+
end
1869
+
else if yes then true
1870
+
else confirm "Proceed?"
1695
1871
in
1696
1872
if not proceed then begin
1697
1873
Fmt.pr "Cancelled.@.";
1698
1874
`Ok ()
1699
-
end else begin
1875
+
end
1876
+
else begin
1700
1877
(* Execute the plan *)
1701
1878
match Monopam.Fork_join.execute_join_plan ~proc ~fs plan with
1702
1879
| Ok result ->
···
1712
1889
`Error (false, "rejoin failed")
1713
1890
end
1714
1891
in
1715
-
Cmd.v info Term.(ret (const run $ name_arg $ dry_run_arg $ yes_arg $ logging_term))
1892
+
Cmd.v info
1893
+
Term.(ret (const run $ name_arg $ dry_run_arg $ yes_arg $ logging_term))
1716
1894
1717
1895
(* Site command *)
1718
1896
···
1722
1900
[
1723
1901
`S Manpage.s_description;
1724
1902
`P
1725
-
"Generates a static index.html file that maps the monoverse, showing all \
1726
-
verse members, their packages, and the relationships between them.";
1903
+
"Generates a static index.html file that maps the monoverse, showing \
1904
+
all verse members, their packages, and the relationships between \
1905
+
them.";
1727
1906
`S "OUTPUT";
1728
1907
`P "The generated site includes:";
1729
-
`I ("Members", "All verse members with links to their monorepo and opam repos");
1908
+
`I
1909
+
( "Members",
1910
+
"All verse members with links to their monorepo and opam repos" );
1730
1911
`I ("Summary", "Overview of common libraries and member-specific packages");
1731
1912
`I ("Repository Details", "Each shared repo with packages and fork status");
1732
1913
`S "FORK STATUS";
···
1754
1935
let info = Cmd.info "site" ~doc ~man in
1755
1936
let output_arg =
1756
1937
let doc = "Output file path. Defaults to mono/index.html." in
1757
-
Arg.(value & opt (some string) None & info [ "o"; "output" ] ~docv:"FILE" ~doc)
1938
+
Arg.(
1939
+
value & opt (some string) None & info [ "o"; "output" ] ~docv:"FILE" ~doc)
1758
1940
in
1759
1941
let stdout_arg =
1760
1942
let doc = "Print HTML to stdout instead of writing to file." in
1761
1943
Arg.(value & flag & info [ "stdout" ] ~doc)
1762
1944
in
1763
1945
let status_arg =
1764
-
let doc = "Include fork status (ahead/behind) for each repository. \
1765
-
This fetches from remotes and may be slower." in
1946
+
let doc =
1947
+
"Include fork status (ahead/behind) for each repository. This fetches \
1948
+
from remotes and may be slower."
1949
+
in
1766
1950
Arg.(value & flag & info [ "status"; "s" ] ~doc)
1767
1951
in
1768
1952
let run output to_stdout with_status () =
···
1774
1958
(* Pull/clone registry to get latest metadata *)
1775
1959
Fmt.pr "Syncing registry...@.";
1776
1960
let registry =
1777
-
match Monopam.Verse_registry.clone_or_pull ~proc ~fs:(fs :> _ Eio.Path.t) ~config:verse_config () with
1961
+
match
1962
+
Monopam.Verse_registry.clone_or_pull ~proc
1963
+
~fs:(fs :> _ Eio.Path.t)
1964
+
~config:verse_config ()
1965
+
with
1778
1966
| Ok r -> r
1779
1967
| Error msg ->
1780
1968
Fmt.epr "Warning: Could not sync registry: %s@." msg;
1781
-
Monopam.Verse_registry.{ name = "opamverse"; description = None; members = [] }
1969
+
Monopam.Verse_registry.
1970
+
{ name = "opamverse"; description = None; members = [] }
1782
1971
in
1783
1972
(* Compute forks if --status is requested *)
1784
1973
let forks =
1785
1974
if with_status then begin
1786
1975
Fmt.pr "Computing fork status...@.";
1787
-
Some (Monopam.Forks.compute ~proc ~fs:(fs :> _ Eio.Path.t)
1788
-
~verse_config ~monopam_config ())
1789
-
end else None
1976
+
Some
1977
+
(Monopam.Forks.compute ~proc
1978
+
~fs:(fs :> _ Eio.Path.t)
1979
+
~verse_config ~monopam_config ())
1980
+
end
1981
+
else None
1790
1982
in
1791
1983
if to_stdout then begin
1792
-
let html = Monopam.Site.generate ~fs:(fs :> _ Eio.Path.t) ~config:verse_config ?forks ~registry () in
1984
+
let html =
1985
+
Monopam.Site.generate
1986
+
~fs:(fs :> _ Eio.Path.t)
1987
+
~config:verse_config ?forks ~registry ()
1988
+
in
1793
1989
print_string html;
1794
1990
`Ok ()
1795
-
end else begin
1991
+
end
1992
+
else begin
1796
1993
let output_path =
1797
1994
match output with
1798
1995
| Some p -> (
1799
1996
match Fpath.of_string p with
1800
1997
| Ok fp -> fp
1801
1998
| Error (`Msg _) -> Fpath.v p)
1802
-
| None -> Fpath.(Monopam.Verse_config.mono_path verse_config / "index.html")
1999
+
| None ->
2000
+
Fpath.(Monopam.Verse_config.mono_path verse_config / "index.html")
1803
2001
in
1804
-
match Monopam.Site.write ~fs:(fs :> _ Eio.Path.t) ~config:verse_config ?forks ~registry ~output_path () with
2002
+
match
2003
+
Monopam.Site.write
2004
+
~fs:(fs :> _ Eio.Path.t)
2005
+
~config:verse_config ?forks ~registry ~output_path ()
2006
+
with
1805
2007
| Ok () ->
1806
2008
Fmt.pr "Site generated: %a@." Fpath.pp output_path;
1807
2009
`Ok ()
···
1810
2012
`Error (false, "site generation failed")
1811
2013
end
1812
2014
in
1813
-
Cmd.v info Term.(ret (const run $ output_arg $ stdout_arg $ status_arg $ logging_term))
2015
+
Cmd.v info
2016
+
Term.(ret (const run $ output_arg $ stdout_arg $ status_arg $ logging_term))
1814
2017
1815
2018
(* Main command group *)
1816
2019
···
1828
2031
pre-installed.";
1829
2032
`S "QUICK START";
1830
2033
`P "Start by creating a devcontainer workspace:";
1831
-
`Pre
1832
-
"monopam devcontainer ~/tangled";
2034
+
`Pre "monopam devcontainer ~/tangled";
1833
2035
`P "Inside the devcontainer, initialize your workspace:";
1834
-
`Pre
1835
-
"cd ~/tangled\n\
1836
-
monopam init --handle yourname.bsky.social\n\
1837
-
cd mono";
2036
+
`Pre "cd ~/tangled\nmonopam init --handle yourname.bsky.social\ncd mono";
1838
2037
`P "Daily workflow:";
1839
2038
`Pre
1840
2039
"cd ~/tangled/mono\n\
···
1913
2112
in
1914
2113
let info = Cmd.info "monopam" ~version:"%%VERSION%%" ~doc ~man in
1915
2114
Cmd.group info
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 ]
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
+
]
1917
2133
1918
-
let () = exit (Cmd.eval main_cmd)
2134
+
let () =
2135
+
Memtrace.trace_if_requested ~context:"monopam" ();
2136
+
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.log_entry) ->
467
+
(fun (commit : Git_cli.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.log_entry) ->
520
+
(fun (commit : Git_cli.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.log_entry list ->
168
+
Git_cli.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.log_entry list ->
177
+
Git_cli.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.log_entry list -> string
183
+
repository:string -> date:string -> Git_cli.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.log_entry list ->
200
+
Git_cli.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.log_entry list ->
212
+
Git_cli.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.
+35
-22
lib/config.ml
+35
-22
lib/config.ml
···
1
1
(** Unified configuration for monopam.
2
2
3
-
Configuration is stored in TOML format at ~/.config/monopam/opamverse.toml *)
3
+
Configuration is stored in TOML format at ~/.config/monopam/opamverse.toml
4
+
*)
4
5
5
6
let app_name = "monopam"
6
7
···
22
23
(** {1 Paths Configuration} *)
23
24
24
25
type paths = {
25
-
mono : string; (** Monorepo directory (default: "mono") *)
26
-
src : string; (** Source checkouts directory (default: "src") *)
26
+
mono : string; (** Monorepo directory (default: "mono") *)
27
+
src : string; (** Source checkouts directory (default: "src") *)
27
28
verse : string; (** Verse directory (default: "verse") *)
28
29
}
29
30
···
86
87
let xdg_cache_home () =
87
88
match Sys.getenv_opt "XDG_CACHE_HOME" with
88
89
| Some dir when dir <> "" -> Fpath.v dir
89
-
| _ ->
90
+
| _ -> (
90
91
match Sys.getenv_opt "HOME" with
91
92
| Some home -> Fpath.(v home / ".cache")
92
-
| None -> Fpath.v "/tmp"
93
+
| None -> Fpath.v "/tmp")
93
94
94
95
let config_dir () = Fpath.(xdg_config_home () / app_name)
95
96
let data_dir () = Fpath.(xdg_data_home () / app_name)
···
99
100
100
101
(** {1 Construction} *)
101
102
102
-
(** Derive knot (git push server) from handle.
103
-
E.g., "anil.recoil.org" -> "git.recoil.org" *)
103
+
(** Derive knot (git push server) from handle. E.g., "anil.recoil.org" ->
104
+
"git.recoil.org" *)
104
105
let default_knot_from_handle handle =
105
106
match String.index_opt handle '.' with
106
107
| None -> "git." ^ handle (* fallback *)
···
109
110
"git." ^ domain
110
111
111
112
let create ~root ~handle ?knot ?(packages = []) ?(paths = default_paths) () =
112
-
let knot = match knot with Some k -> k | None -> default_knot_from_handle handle in
113
+
let knot =
114
+
match knot with Some k -> k | None -> default_knot_from_handle handle
115
+
in
113
116
{ root; handle; knot; packages; paths }
114
117
115
118
let with_package_override t ~name ?branch:branch_opt () =
···
145
148
Tomlt.(
146
149
Table.(
147
150
obj (fun mono src verse ->
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 })
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
+
})
151
156
|> opt_mem "mono" string ~enc:(fun p -> Some p.mono)
152
157
|> opt_mem "src" string ~enc:(fun p -> Some p.src)
153
158
|> opt_mem "verse" string ~enc:(fun p -> Some p.verse)
···
194
199
Tomlt.(
195
200
Table.(
196
201
obj (fun pkgs -> pkgs)
197
-
|> keep_unknown ~enc:(fun pkgs -> pkgs)
198
-
(Mems.assoc Package_config.codec)
202
+
|> keep_unknown ~enc:(fun pkgs -> pkgs) (Mems.assoc Package_config.codec)
199
203
|> finish))
200
204
201
205
let codec : t Tomlt.t =
···
205
209
let packages = Option.value ~default:[] packages in
206
210
let paths = Option.value ~default:default_paths paths in
207
211
let knot = Option.value ~default:default_knot identity.i_knot in
208
-
{ root = workspace.w_root; handle = identity.i_handle; knot; packages; paths })
212
+
{
213
+
root = workspace.w_root;
214
+
handle = identity.i_handle;
215
+
knot;
216
+
packages;
217
+
paths;
218
+
})
209
219
|> mem "workspace" workspace_codec ~enc:(fun t -> { w_root = t.root })
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)
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)
215
226
|> finish))
216
227
217
228
(** {1 Validation} *)
···
250
261
| `Regular_file -> (
251
262
try Ok (Tomlt_eio.decode_path_exn codec ~fs path_str) with
252
263
| Failure msg -> Error (Printf.sprintf "Invalid config: %s" msg)
253
-
| exn -> Error (Printf.sprintf "Error loading config: %s" (Printexc.to_string exn)))
264
+
| exn ->
265
+
Error
266
+
(Printf.sprintf "Error loading config: %s" (Printexc.to_string exn))
267
+
)
254
268
| _ -> Error (Printf.sprintf "Config file not found: %s" path_str)
255
269
| exception _ -> Error (Printf.sprintf "Config file not found: %s" path_str)
256
270
···
273
287
@[<hov 2>identity:@ handle=%s@ knot=%s@]@,\
274
288
@[<hov 2>paths:@ mono=%s@ src=%s@ verse=%s@]@,\
275
289
packages=%d@]"
276
-
Fpath.pp t.root t.handle t.knot
277
-
t.paths.mono t.paths.src t.paths.verse
290
+
Fpath.pp t.root t.handle t.knot t.paths.mono t.paths.src t.paths.verse
278
291
(List.length t.packages)
+13
-11
lib/config.mli
+13
-11
lib/config.mli
···
1
1
(** Unified configuration for monopam.
2
2
3
-
Configuration is stored in TOML format at [~/.config/monopam/opamverse.toml].
3
+
Configuration is stored in TOML format at
4
+
[~/.config/monopam/opamverse.toml].
4
5
5
6
The config stores:
6
7
- Workspace root and custom paths
···
24
25
(** [branch t] returns the branch override for this package, if set. *)
25
26
end
26
27
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
+
}
27
33
(** Configurable paths within the workspace.
28
34
29
35
By default, paths are:
···
32
38
- [verse = "verse"] - verse directory
33
39
34
40
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
-
}
40
41
41
42
val default_paths : paths
42
43
(** Default paths configuration. *)
···
53
54
(** [handle t] returns the user's handle. *)
54
55
55
56
val knot : t -> string
56
-
(** [knot t] returns the git push server hostname (e.g., "git.recoil.org").
57
-
Used for converting tangled URLs to SSH push URLs. *)
57
+
(** [knot t] returns the git push server hostname (e.g., "git.recoil.org"). Used
58
+
for converting tangled URLs to SSH push URLs. *)
58
59
59
60
val paths : t -> paths
60
61
(** [paths t] returns the paths configuration. *)
···
129
130
?paths:paths ->
130
131
unit ->
131
132
t
132
-
(** [create ~root ~handle ?knot ?packages ?paths ()] creates a new configuration.
133
+
(** [create ~root ~handle ?knot ?packages ?paths ()] creates a new
134
+
configuration.
133
135
134
136
@param root Workspace root directory (absolute path)
135
137
@param handle User's handle
···
138
140
@param paths Optional custom paths configuration *)
139
141
140
142
val with_package_override : t -> name:string -> ?branch:string -> unit -> t
141
-
(** [with_package_override t ~name ?branch ()] returns a new config
142
-
with overrides for the named package. *)
143
+
(** [with_package_override t ~name ?branch ()] returns a new config with
144
+
overrides for the named package. *)
143
145
144
146
(** {1 Validation} *)
145
147
+13
-12
lib/cross_status.ml
+13
-12
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.subtree_last_upstream_commit ~proc ~fs ~repo:monorepo_path ~prefix ()
144
+
Git_cli.subtree_last_upstream_commit ~proc ~fs ~repo:monorepo_path ~prefix
145
+
()
145
146
in
146
147
{ monorepo_path; prefix; upstream_commit }
147
148
···
154
155
| Some my, Some their when my = their -> Same
155
156
| Some my, Some their ->
156
157
(* Try to compare using checkout if available *)
157
-
if not (Git.is_repo ~proc ~fs checkout_path) then Unknown
158
+
if not (Git_cli.is_repo ~proc ~fs checkout_path) then Unknown
158
159
else begin
159
160
(* Check if either is ancestor of the other *)
160
161
let my_is_ancestor =
161
-
Git.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:my
162
+
Git_cli.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:my
162
163
~commit2:their ()
163
164
in
164
165
let their_is_ancestor =
165
-
Git.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:their
166
+
Git_cli.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:their
166
167
~commit2:my ()
167
168
in
168
169
match (my_is_ancestor, their_is_ancestor) with
169
170
| true, false ->
170
171
(* My commit is ancestor of theirs -> I'm behind *)
171
172
let behind =
172
-
Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base:my
173
-
~head:their ()
173
+
Git_cli.count_commits_between ~proc ~fs ~repo:checkout_path
174
+
~base:my ~head:their ()
174
175
in
175
176
I_am_behind behind
176
177
| false, true ->
177
178
(* Their commit is ancestor of mine -> I'm ahead *)
178
179
let ahead =
179
-
Git.count_commits_between ~proc ~fs ~repo:checkout_path
180
+
Git_cli.count_commits_between ~proc ~fs ~repo:checkout_path
180
181
~base:their ~head:my ()
181
182
in
182
183
I_am_ahead ahead
···
186
187
| false, false -> (
187
188
(* Neither is ancestor -> diverged *)
188
189
match
189
-
Git.merge_base ~proc ~fs ~repo:checkout_path ~commit1:my
190
+
Git_cli.merge_base ~proc ~fs ~repo:checkout_path ~commit1:my
190
191
~commit2:their ()
191
192
with
192
193
| Error _ -> Unknown
193
194
| Ok base ->
194
195
let my_ahead =
195
-
Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base
196
-
~head:my ()
196
+
Git_cli.count_commits_between ~proc ~fs ~repo:checkout_path
197
+
~base ~head:my ()
197
198
in
198
199
let their_ahead =
199
-
Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base
200
-
~head:their ()
200
+
Git_cli.count_commits_between ~proc ~fs ~repo:checkout_path
201
+
~base ~head:their ()
201
202
in
202
203
Diverged { my_ahead; their_ahead })
203
204
end
+11
-14
lib/doctor.ml
+11
-14
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.log_entry list;
366
+
incoming_commits : Git_cli.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.get_remote_url ~proc ~fs ~remote:remote_name checkout_dir
374
+
Git_cli.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.ahead_behind ~proc ~fs ~remote:remote_name checkout_dir with
379
+
match Git_cli.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.log_range ~proc ~fs ~base:"HEAD" ~tip ~max_count:20 checkout_dir
388
+
Git_cli.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.log_range ~proc ~fs ~base:"HEAD"
394
+
Git_cli.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.list_remotes ~proc ~fs checkout_dir in
406
+
let remotes = Git_cli.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.log_entry) ->
486
+
(fun (c : Git_cli.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 ~proc ~fs ~config packages in
925
+
let statuses = Status.compute_all ~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.is_dirty ~proc ~fs opam_repo then
942
+
if Git_cli.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.is_dirty ~proc ~fs monorepo then
947
+
if Git_cli.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
1136
-
| Healthy -> 0
1137
-
| Warning -> 1
1138
-
| Critical -> 2
1135
+
let health_to_exit_code = function Healthy -> 0 | Warning -> 1 | Critical -> 2
1139
1136
1140
1137
(** Compute overall health status from a report.
1141
1138
- Critical: has critical/high priority issues or warnings
+2
-1
lib/dune
+2
-1
lib/dune
+14
-19
lib/dune_project.ml
+14
-19
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 } (** tangled.org style sources *)
6
+
| Tangled of { host : string; repo : string }
7
+
(** tangled.org style sources *)
7
8
| Uri of { url : string; branch : string option }
8
9
9
10
type t = {
···
16
17
module Sexp = Sexplib0.Sexp
17
18
18
19
(** Extract string from a Sexp.Atom, or None if it's a List *)
19
-
let atom_string = function
20
-
| Sexp.Atom s -> Some s
21
-
| Sexp.List _ -> None
20
+
let atom_string = function Sexp.Atom s -> Some s | Sexp.List _ -> None
22
21
23
22
(** Parse source stanza: (source (github user/repo)) or (source (uri "url")) *)
24
23
let parse_source_inner sexp =
···
36
35
match String.index_opt host_repo '/' with
37
36
| Some i ->
38
37
let host = String.sub host_repo 0 i in
39
-
let repo = String.sub host_repo (i + 1) (String.length host_repo - i - 1) in
38
+
let repo =
39
+
String.sub host_repo (i + 1) (String.length host_repo - i - 1)
40
+
in
40
41
Some (Tangled { host; repo })
41
42
| None -> None)
42
43
| Sexp.List [ Sexp.Atom "uri"; Sexp.Atom url ] ->
43
44
(* Check for branch in URI fragment *)
44
45
let uri = Uri.of_string url in
45
46
let branch = Uri.fragment uri in
46
-
let url_without_fragment =
47
-
Uri.with_fragment uri None |> Uri.to_string
48
-
in
47
+
let url_without_fragment = Uri.with_fragment uri None |> Uri.to_string in
49
48
Some (Uri { url = url_without_fragment; branch })
50
49
| Sexp.Atom url ->
51
50
(* Single atom URL (unlikely but handle it) *)
52
51
let uri = Uri.of_string url in
53
52
let branch = Uri.fragment uri in
54
-
let url_without_fragment =
55
-
Uri.with_fragment uri None |> Uri.to_string
56
-
in
53
+
let url_without_fragment = Uri.with_fragment uri None |> Uri.to_string in
57
54
Some (Uri { url = url_without_fragment; branch })
58
55
| _ -> None
59
56
···
90
87
let parse content =
91
88
match Parsexp.Many.parse_string content with
92
89
| Error err ->
93
-
Error (Printf.sprintf "S-expression parse error: %s"
94
-
(Parsexp.Parse_error.message err))
90
+
Error
91
+
(Printf.sprintf "S-expression parse error: %s"
92
+
(Parsexp.Parse_error.message err))
95
93
| Ok sexps -> (
96
94
match find_string_field "name" sexps with
97
95
| None -> Error "dune-project missing (name ...) stanza"
···
112
110
113
111
(** Ensure URL ends with .git *)
114
112
let ensure_git_suffix url =
115
-
if String.ends_with ~suffix:".git" url then url
116
-
else url ^ ".git"
113
+
if String.ends_with ~suffix:".git" url then url else url ^ ".git"
117
114
118
115
let dev_repo_url t =
119
116
match t.source with
···
124
121
| Some (Tangled { host; repo }) ->
125
122
(* Tangled sources: https://tangled.sh/@handle/repo *)
126
123
Ok (Printf.sprintf "git+https://tangled.sh/@%s/%s.git" host repo)
127
-
| Some (Uri { url; _ }) ->
128
-
Ok (normalize_git_url (ensure_git_suffix url))
124
+
| Some (Uri { url; _ }) -> Ok (normalize_git_url (ensure_git_suffix url))
129
125
| None -> (
130
126
match t.homepage with
131
-
| Some homepage ->
132
-
Ok (normalize_git_url (ensure_git_suffix homepage))
127
+
| Some homepage -> Ok (normalize_git_url (ensure_git_suffix homepage))
133
128
| None ->
134
129
Error
135
130
(Printf.sprintf
+7
-6
lib/dune_project.mli
+7
-6
lib/dune_project.mli
···
1
1
(** Dune project file parsing.
2
2
3
-
Parse dune-project s-expressions to extract package metadata needed
4
-
for generating opam-repo entries. *)
3
+
Parse dune-project s-expressions to extract package metadata needed for
4
+
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. *)
14
13
type t = {
15
14
name : string; (** Project name from (name ...) stanza *)
16
15
source : source_info option; (** Source from (source ...) stanza *)
17
16
homepage : string option; (** Homepage from (homepage ...) stanza *)
18
17
packages : string list; (** Package names from (package (name ...)) stanzas *)
19
18
}
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., "git+https://...").
27
+
Returns a URL suitable for the opam dev-repo field (e.g.,
28
+
"git+https://...").
28
29
29
30
URL derivation logic:
30
31
- [Github {user; repo}] -> "git+https://github.com/user/repo.git"
···
34
35
- Neither source nor homepage -> Error *)
35
36
36
37
val url_with_branch : t -> (string, string) result
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").
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").
39
40
40
41
Branch derivation:
41
42
- [Uri {url; branch = Some b}] -> url#b
+34
-26
lib/feature.ml
+34
-26
lib/feature.ml
···
1
1
type error =
2
-
| Git_error of Git.error
2
+
| Git_error of Git_cli.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.pp_error e
8
+
| Git_error e -> Fmt.pf ppf "Git error: %a" Git_cli.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 (Printf.sprintf "Run 'monopam feature remove %s' first if you want to recreate it" name)
16
+
Some
17
+
(Printf.sprintf
18
+
"Run 'monopam feature remove %s' first if you want to recreate it"
19
+
name)
17
20
| Feature_not_found name ->
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"
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"
20
28
21
29
let pp_error_with_hint ppf e =
22
30
pp_error ppf e;
···
24
32
| Some hint -> Fmt.pf ppf "@.Hint: %s" hint
25
33
| None -> ()
26
34
27
-
type entry = {
28
-
name : string;
29
-
path : Fpath.t;
30
-
branch : string;
31
-
}
35
+
type entry = { name : string; path : Fpath.t; branch : string }
32
36
33
37
let pp_entry ppf e =
34
38
Fmt.pf ppf "%s -> %a (branch: %s)" e.name Fpath.pp e.path e.branch
···
44
48
let work_dir = work_path config in
45
49
let wt_path = feature_path config name in
46
50
(* Check if feature already exists *)
47
-
if Git.Worktree.exists ~proc ~fs ~repo:mono ~path:wt_path then
51
+
if Git_cli.Worktree.exists ~proc ~fs ~repo:mono ~path:wt_path then
48
52
Error (Feature_exists name)
49
53
else begin
50
54
(* Ensure work directory exists *)
51
55
let work_eio = Eio.Path.(fs / Fpath.to_string work_dir) in
52
56
(try Eio.Path.mkdirs ~perm:0o755 work_eio with Eio.Io _ -> ());
53
57
(* Create the worktree with a new branch *)
54
-
match Git.Worktree.add ~proc ~fs ~repo:mono ~path:wt_path ~branch:name () with
58
+
match
59
+
Git_cli.Worktree.add ~proc ~fs ~repo:mono ~path:wt_path ~branch:name ()
60
+
with
55
61
| Error e -> Error (Git_error e)
56
62
| Ok () -> Ok { name; path = wt_path; branch = name }
57
63
end
···
60
66
let mono = Verse_config.mono_path config in
61
67
let wt_path = feature_path config name in
62
68
(* Check if feature exists *)
63
-
if not (Git.Worktree.exists ~proc ~fs ~repo:mono ~path:wt_path) then
69
+
if not (Git_cli.Worktree.exists ~proc ~fs ~repo:mono ~path:wt_path) then
64
70
Error (Feature_not_found name)
65
71
else
66
-
match Git.Worktree.remove ~proc ~fs ~repo:mono ~path:wt_path ~force () with
72
+
match
73
+
Git_cli.Worktree.remove ~proc ~fs ~repo:mono ~path:wt_path ~force ()
74
+
with
67
75
| Error e -> Error (Git_error e)
68
76
| Ok () -> Ok ()
69
77
70
78
let list ~proc ~fs ~config () =
71
79
let mono = Verse_config.mono_path config in
72
80
let work_dir = work_path config in
73
-
let all_worktrees = Git.Worktree.list ~proc ~fs mono in
81
+
let all_worktrees = Git_cli.Worktree.list ~proc ~fs mono in
74
82
(* Filter to only worktrees under work/ directory *)
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
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
+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.error (** Git operation error *)
10
+
| Git_error of Git_cli.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. *)
22
21
type entry = {
23
22
name : string; (** Feature name *)
24
23
path : Fpath.t; (** Path to the worktree *)
25
24
branch : string; (** Branch name *)
26
25
}
26
+
(** A feature worktree entry. *)
27
27
28
28
val pp_entry : entry Fmt.t
29
29
(** [pp_entry] formats a feature entry. *)
+643
-383
lib/fork_join.ml
+643
-383
lib/fork_join.ml
···
2
2
3
3
type error =
4
4
| Config_error of string
5
-
| Git_error of Git.error
5
+
| Git_error of Git_cli.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 } (** 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 }
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 }
30
37
| Git_add_all of Fpath.t
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 }
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
+
}
34
46
35
-
(** Discovery information gathered during planning *)
36
47
type discovery = {
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 *)
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 *)
43
54
}
55
+
(** Discovery information gathered during planning *)
44
56
45
-
(** A complete action plan *)
46
57
type 'a action_plan = {
47
-
discovery: discovery;
48
-
actions: action list;
49
-
result: 'a; (** What we'll return on success *)
50
-
dry_run: bool;
58
+
discovery : discovery;
59
+
actions : action list;
60
+
result : 'a; (** What we'll return on success *)
61
+
dry_run : bool;
51
62
}
63
+
(** A complete action plan *)
52
64
53
65
let pp_error ppf = function
54
66
| Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
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
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
58
72
| Src_not_found name -> Fmt.pf ppf "Source checkout not found: src/%s" name
59
-
| Subtree_already_exists name -> Fmt.pf ppf "Subtree already exists in monorepo: mono/%s" name
73
+
| Subtree_already_exists name ->
74
+
Fmt.pf ppf "Subtree already exists in monorepo: mono/%s" name
60
75
| No_opam_files name -> Fmt.pf ppf "No .opam files found in subtree: %s" name
61
76
| Verse_error e -> Fmt.pf ppf "Verse error: %a" Verse.pp_error e
62
77
| User_cancelled -> Fmt.pf ppf "Operation cancelled by user"
···
64
79
let error_hint = function
65
80
| Config_error _ ->
66
81
Some "Run 'monopam init --handle <your-handle>' to create a workspace."
67
-
| Git_error (Git.Dirty_worktree _) ->
82
+
| Git_error (Git_cli.Dirty_worktree _) ->
68
83
Some "Commit or stash your changes first: git status"
69
84
| Git_error _ -> None
70
85
| Subtree_not_found name ->
71
86
Some (Fmt.str "Check that mono/%s exists in your monorepo" name)
72
87
| Src_already_exists name ->
73
-
Some (Fmt.str "Remove or rename src/%s first, or choose a different name" name)
88
+
Some
89
+
(Fmt.str "Remove or rename src/%s first, or choose a different name"
90
+
name)
74
91
| Src_not_found name ->
75
92
Some (Fmt.str "Run 'monopam fork %s' first to create src/%s" name name)
76
93
| Subtree_already_exists name ->
77
-
Some (Fmt.str "Remove mono/%s first, or use a different name with --as" name)
94
+
Some
95
+
(Fmt.str "Remove mono/%s first, or use a different name with --as" name)
78
96
| No_opam_files name ->
79
97
Some (Fmt.str "Add a .opam file to mono/%s before forking" name)
80
98
| Verse_error e -> Verse.error_hint e
···
83
101
(** {1 Pretty Printers for Actions and Discovery} *)
84
102
85
103
let pp_action ppf = function
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
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
92
107
| Git_config { repo = _; key; value } ->
93
108
Fmt.pf ppf "Set git config %s = %s" key value
94
109
| Git_clone { url; dest; branch } ->
···
96
111
| Git_subtree_split { repo = _; prefix } ->
97
112
Fmt.pf ppf "Split subtree history for '%s'" prefix
98
113
| Git_subtree_add { repo = _; prefix; url; branch } ->
99
-
Fmt.pf ppf "Add subtree '%s' from %s (branch: %s)" prefix (Uri.to_string url) branch
114
+
Fmt.pf ppf "Add subtree '%s' from %s (branch: %s)" prefix
115
+
(Uri.to_string url) branch
100
116
| Git_add_remote { repo = _; name; url } ->
101
117
Fmt.pf ppf "Add remote '%s' -> %s" name url
102
118
| Git_push_ref { repo = _; target; ref_spec } ->
···
107
123
Fmt.pf ppf "Rename current branch to '%s'" new_name
108
124
| Copy_directory { src; dest } ->
109
125
Fmt.pf ppf "Copy files from %a to %a" Fpath.pp src Fpath.pp dest
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
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
114
128
| Git_rm { repo = _; path; recursive = _ } ->
115
129
Fmt.pf ppf "Remove '%s' from git" path
116
130
| Update_sources_toml { path = _; name; entry = _ } ->
···
125
139
Fmt.pf ppf " Subtree history: %s@,"
126
140
(if d.has_subtree_history then "present" else "none (fresh package)");
127
141
(match d.remote_accessible with
128
-
| None -> ()
129
-
| Some true -> Fmt.pf ppf " Remote accessible: yes@,"
130
-
| Some false -> Fmt.pf ppf " Remote accessible: no@,");
142
+
| None -> ()
143
+
| Some true -> Fmt.pf ppf " Remote accessible: yes@,"
144
+
| Some false -> Fmt.pf ppf " Remote accessible: no@,");
131
145
(match d.local_path_is_repo with
132
-
| None -> ()
133
-
| Some true -> Fmt.pf ppf " Is git repo: yes@,"
134
-
| Some false -> Fmt.pf ppf " Is git repo: no@,");
146
+
| None -> ()
147
+
| Some true -> Fmt.pf ppf " Is git repo: yes@,"
148
+
| Some false -> Fmt.pf ppf " Is git repo: no@,");
135
149
if d.opam_files <> [] then
136
-
Fmt.pf ppf " Packages found: %a@," Fmt.(list ~sep:(any ", ") string) d.opam_files;
150
+
Fmt.pf ppf " Packages found: %a@,"
151
+
Fmt.(list ~sep:(any ", ") string)
152
+
d.opam_files;
137
153
Fmt.pf ppf "@]"
138
154
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)@,";
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)@,";
146
163
Fmt.pf ppf "@,Expected result:@, %a@]" pp_result plan.result
147
164
148
165
let pp_error_with_hint ppf e =
···
170
187
let pp_fork_result ppf (r : fork_result) =
171
188
(* Only truncate if it looks like a git SHA (40 hex chars), otherwise show full string *)
172
189
let commit_display =
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
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
175
195
then String.sub r.split_commit 0 7
176
196
else r.split_commit
177
197
in
178
198
Fmt.pf ppf "@[<v>Forked subtree '%s':@, Split commit: %s@, Local repo: %a@,"
179
199
r.name commit_display Fpath.pp r.src_path;
180
200
(match r.push_url with
181
-
| Some url -> Fmt.pf ppf " Push URL: %s@," url
182
-
| None -> ());
201
+
| Some url -> Fmt.pf ppf " Push URL: %s@," url
202
+
| None -> ());
183
203
if r.packages_created <> [] then
184
-
Fmt.pf ppf " Packages: %a@]" Fmt.(list ~sep:(any ", ") string) r.packages_created
185
-
else
186
-
Fmt.pf ppf "@]"
204
+
Fmt.pf ppf " Packages: %a@]"
205
+
Fmt.(list ~sep:(any ", ") string)
206
+
r.packages_created
207
+
else Fmt.pf ppf "@]"
187
208
188
209
let pp_join_result ppf (r : join_result) =
189
-
Fmt.pf ppf "@[<v>Joined repository '%s':@, Source: %s@,"
190
-
r.name r.source_url;
210
+
Fmt.pf ppf "@[<v>Joined repository '%s':@, Source: %s@," r.name r.source_url;
191
211
(match r.upstream_url with
192
-
| Some url -> Fmt.pf ppf " Upstream: %s@," url
193
-
| None -> ());
212
+
| Some url -> Fmt.pf ppf " Upstream: %s@," url
213
+
| None -> ());
194
214
(match r.from_handle with
195
-
| Some h -> Fmt.pf ppf " From verse: %s@," h
196
-
| None -> ());
215
+
| Some h -> Fmt.pf ppf " From verse: %s@," h
216
+
| None -> ());
197
217
if r.packages_added <> [] then
198
-
Fmt.pf ppf " Packages: %a@]" Fmt.(list ~sep:(any ", ") string) r.packages_added
199
-
else
200
-
Fmt.pf ppf "@]"
218
+
Fmt.pf ppf " Packages: %a@]"
219
+
Fmt.(list ~sep:(any ", ") string)
220
+
r.packages_added
221
+
else Fmt.pf ppf "@]"
201
222
202
223
(** Helper to check if a path is a directory *)
203
224
let is_directory ~fs path =
···
236
257
| Some "tangled.org" | Some "tangled.sh" -> true
237
258
| _ -> false
238
259
239
-
(** Convert a dev-repo URL to a push URL (SSH format for github/gitlab/tangled) *)
260
+
(** Convert a dev-repo URL to a push URL (SSH format for github/gitlab/tangled)
261
+
*)
240
262
let url_to_push_url ?knot url =
241
263
(* Strip git+ prefix if present *)
242
264
let url =
···
302
324
(* For SSH URLs like git@github.com:user/repo.git *)
303
325
if String.starts_with ~prefix:"git@" url then
304
326
match String.index_opt url ':' with
305
-
| Some i ->
327
+
| Some i -> (
306
328
let path = String.sub url (i + 1) (String.length url - i - 1) in
307
329
(* path is like "user/repo.git" or "handle/repo" *)
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)
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)
319
341
| None -> false
320
342
else
321
343
(* For HTTPS URLs like https://github.com/user/repo.git *)
···
351
373
let content = Eio.Path.load eio_path in
352
374
match Dune_project.parse content with
353
375
| Error _ -> None
354
-
| Ok dune_proj ->
376
+
| Ok dune_proj -> (
355
377
match Dune_project.dev_repo_url dune_proj with
356
378
| Error _ -> None
357
-
| Ok dev_repo -> Some (url_to_push_url ?knot dev_repo)
379
+
| Ok dev_repo -> Some (url_to_push_url ?knot dev_repo))
358
380
with Eio.Io _ -> None
359
381
360
382
(** Extract name from URL (last path component without .git suffix) *)
···
362
384
let uri = Uri.of_string url in
363
385
let path = Uri.path uri in
364
386
(* Remove leading slash and .git suffix *)
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
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
371
397
(* Get last component *)
372
398
match String.rindex_opt path '/' with
373
399
| Some i -> String.sub path (i + 1) (String.length path - i - 1)
···
378
404
(** Determine if input is a local path or URL *)
379
405
let is_local_path s =
380
406
(* It's a URL if it starts with a scheme or looks like SSH URL *)
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)
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)
387
414
388
415
(** Copy a directory tree recursively *)
389
416
let copy_directory ~fs ~src ~dest =
···
393
420
match Eio.Path.kind ~follow:false src_path with
394
421
| `Directory ->
395
422
(try Eio.Path.mkdirs ~perm:0o755 dest_path with Eio.Io _ -> ());
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)
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)
404
432
| `Regular_file ->
405
433
let content = Eio.Path.load src_path in
406
434
Eio.Path.save ~create:(`Or_truncate 0o644) dest_path content
407
-
| `Symbolic_link ->
435
+
| `Symbolic_link -> (
408
436
(* Read symlink target and recreate it *)
409
437
let target = Eio.Path.read_link src_path in
410
-
(try Unix.symlink target (snd dest_path) with _ -> ())
411
-
| _ -> () (* Skip other file types *)
438
+
try Unix.symlink target (snd dest_path) with _ -> ())
439
+
| _ -> () (* Skip other file types *)
412
440
| exception _ -> ()
413
441
in
414
442
copy_rec src_eio dest_eio
···
417
445
418
446
(** Build a fork plan - handles both subtree and fresh package scenarios.
419
447
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>/
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>/
424
451
425
452
This ensures the subtree relationship is properly established for sync. *)
426
453
let plan_fork ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () =
···
432
459
let branch = Verse_config.default_branch in
433
460
434
461
(* Gather discovery information *)
435
-
let mono_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix in
462
+
let mono_exists = Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix in
436
463
let src_exists = is_directory ~fs src_path in
437
464
let has_subtree_hist =
438
-
if mono_exists then Git.has_subtree_history ~proc ~fs ~repo:monorepo ~prefix ()
465
+
if mono_exists then
466
+
Git_cli.has_subtree_history ~proc ~fs ~repo:monorepo ~prefix ()
439
467
else false
440
468
in
441
469
let opam_files =
442
-
if mono_exists then find_opam_files ~fs subtree_path
443
-
else []
470
+
if mono_exists then find_opam_files ~fs subtree_path else []
444
471
in
445
472
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
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
454
484
455
485
(* Validation *)
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)
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)
462
489
else begin
463
490
(* Build actions for complete fork workflow:
464
491
1. Create src/<name>/ with content
···
472
499
Git_subtree_split { repo = monorepo; prefix };
473
500
Git_init src_path;
474
501
(* Allow pushing to checked-out branch (for monopam sync) *)
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" };
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
+
};
478
516
Git_checkout { repo = src_path; branch };
479
517
]
480
518
else
···
484
522
Create_directory src_path;
485
523
Git_init src_path;
486
524
(* Allow pushing to checked-out branch (for monopam sync) *)
487
-
Git_config { repo = src_path; key = "receive.denyCurrentBranch"; value = "updateInstead" };
525
+
Git_config
526
+
{
527
+
repo = src_path;
528
+
key = "receive.denyCurrentBranch";
529
+
value = "updateInstead";
530
+
};
488
531
Git_branch_rename { repo = src_path; new_name = branch };
489
532
Copy_directory { src = subtree_path; dest = src_path };
490
533
Git_add_all src_path;
491
-
Git_commit { repo = src_path; message = Fmt.str "Initial commit of %s" name };
534
+
Git_commit
535
+
{ repo = src_path; message = Fmt.str "Initial commit of %s" name };
492
536
]
493
537
in
494
538
495
539
(* Add remote if push_url provided *)
496
-
let remote_actions = match push_url with
540
+
let remote_actions =
541
+
match push_url with
497
542
| Some url -> [ Git_add_remote { repo = src_path; name = "origin"; url } ]
498
543
| None -> []
499
544
in
500
545
501
546
(* Remove from mono and re-add as subtree *)
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
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
507
561
508
562
(* Update sources.toml only if push_url is a true fork (different namespace) *)
509
563
let handle = Verse_config.handle config in
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 *)
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 *)
525
584
| None -> []
526
585
in
527
586
528
-
let actions = create_src_actions @ remote_actions @ rejoin_actions @ sources_actions in
587
+
let actions =
588
+
create_src_actions @ remote_actions @ rejoin_actions @ sources_actions
589
+
in
529
590
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
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
537
601
538
602
Ok { discovery; actions; result; dry_run }
539
603
end
···
548
612
let src_path = Fpath.(checkouts / name) in
549
613
550
614
(* Gather discovery information *)
551
-
let subtree_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix in
615
+
let subtree_exists =
616
+
Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix
617
+
in
552
618
let src_exists = is_directory ~fs src_path in
553
619
let local_is_repo =
554
620
if is_local then begin
555
621
match Fpath.of_string source with
556
-
| Ok path -> Some (Git.is_repo ~proc ~fs path)
622
+
| Ok path -> Some (Git_cli.is_repo ~proc ~fs path)
557
623
| Error _ -> Some false
558
-
end else None
624
+
end
625
+
else None
559
626
in
560
627
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
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
569
639
570
640
(* Validation *)
571
-
if subtree_exists then
572
-
Error (Subtree_already_exists name)
641
+
if subtree_exists then Error (Subtree_already_exists name)
573
642
else begin
574
643
let branch = Verse_config.default_branch in
575
644
let actions =
···
584
653
[
585
654
Create_directory checkouts;
586
655
Copy_directory { src = local_path; dest = src_path };
587
-
Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch };
656
+
Git_subtree_add
657
+
{
658
+
repo = monorepo;
659
+
prefix;
660
+
url = Uri.of_string (Fpath.to_string src_path);
661
+
branch;
662
+
};
588
663
]
589
664
else
590
665
(* Local directory without git - init and commit first *)
···
594
669
Git_init src_path;
595
670
Copy_directory { src = local_path; dest = src_path };
596
671
Git_add_all src_path;
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 };
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
+
};
600
686
]
601
-
end else begin
687
+
end
688
+
else begin
602
689
(* Join from URL (existing behavior) *)
603
690
let url_uri = Uri.of_string source in
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
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
610
700
| Some _ ->
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
-
}]
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
+
]
622
717
| None -> []
623
718
in
624
719
base_actions @ sources_actions
···
634
729
else []
635
730
in
636
731
637
-
let result = {
638
-
name;
639
-
source_url = source;
640
-
upstream_url = upstream;
641
-
packages_added = opam_preview;
642
-
from_handle = None;
643
-
} in
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
644
741
645
-
Ok { discovery = { discovery with opam_files = opam_preview }; actions; result; dry_run }
742
+
Ok
743
+
{
744
+
discovery = { discovery with opam_files = opam_preview };
745
+
actions;
746
+
result;
747
+
dry_run;
748
+
}
646
749
end
647
750
648
751
(** Build a rejoin plan - add existing src/<name> back into mono/<name> *)
···
653
756
let src_path = Fpath.(checkouts / name) in
654
757
655
758
(* Gather discovery information *)
656
-
let subtree_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix in
759
+
let subtree_exists =
760
+
Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix
761
+
in
657
762
let src_exists = is_directory ~fs src_path in
658
-
let src_is_repo = if src_exists then Git.is_repo ~proc ~fs src_path else false in
763
+
let src_is_repo =
764
+
if src_exists then Git_cli.is_repo ~proc ~fs src_path else false
765
+
in
659
766
let opam_files = if src_exists then find_opam_files ~fs src_path else [] in
660
767
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
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
669
778
670
779
(* Validation *)
671
-
if subtree_exists then
672
-
Error (Subtree_already_exists name)
673
-
else if not src_exists then
674
-
Error (Src_not_found name)
780
+
if subtree_exists then Error (Subtree_already_exists name)
781
+
else if not src_exists then Error (Src_not_found name)
675
782
else if not src_is_repo then
676
-
Error (Config_error (Fmt.str "src/%s exists but is not a git repository" name))
783
+
Error
784
+
(Config_error (Fmt.str "src/%s exists but is not a git repository" name))
677
785
else begin
678
786
let branch = Verse_config.default_branch in
679
-
let actions = [
680
-
Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch };
681
-
] 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
682
798
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
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
690
808
691
809
Ok { discovery; actions; result; dry_run }
692
810
end
693
811
694
812
(** {1 Plan Execution} *)
695
813
814
+
type exec_state = { mutable split_commit : string option }
696
815
(** State tracked during plan execution *)
697
-
type exec_state = {
698
-
mutable split_commit: string option;
699
-
}
700
816
701
817
(** Execute a single action *)
702
818
let execute_action ~proc ~fs ~state action =
···
708
824
ensure_dir ~fs path;
709
825
Ok ()
710
826
| Git_init path ->
711
-
Git.init ~proc ~fs path |> Result.map_error (fun e -> Git_error e)
827
+
Git_cli.init ~proc ~fs path |> Result.map_error (fun e -> Git_error e)
712
828
| Git_config { repo; key; value } ->
713
-
Git.config ~proc ~fs ~key ~value repo |> Result.map_error (fun e -> Git_error e)
714
-
| Git_clone { url; dest; branch } ->
715
-
Git.clone ~proc ~fs ~url:(Uri.of_string url) ~branch dest
716
-
|> Result.map_error (fun e -> Git_error e)
717
-
| Git_subtree_split { repo; prefix } ->
718
-
Git.Subtree.split ~proc ~fs ~repo ~prefix ()
719
-
|> Result.map (fun commit -> state.split_commit <- Some commit)
829
+
Git_cli.config ~proc ~fs ~key ~value repo
720
830
|> 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 ()
831
+
| Git_clone { url; dest; branch } ->
832
+
Git_cli.clone ~proc ~fs ~url:(Uri.of_string url) ~branch dest
723
833
|> 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))))
724
869
| Git_add_remote { repo; name; url } ->
725
-
Git.add_remote ~proc ~fs ~name ~url repo
870
+
Git_cli.add_remote ~proc ~fs ~name ~url repo
726
871
|> Result.map_error (fun e -> Git_error e)
727
872
| Git_push_ref { repo; target; ref_spec } ->
728
873
(* Replace SPLIT_COMMIT placeholder with actual commit if available *)
729
874
let ref_spec =
730
875
match state.split_commit with
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
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
735
885
| None -> ref_spec
736
886
in
737
887
(* Better replacement: look for SPLIT_COMMIT literal *)
738
888
let ref_spec =
739
889
match state.split_commit with
740
890
| Some commit ->
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)
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)
743
895
else ref_spec
744
896
| None -> ref_spec
745
897
in
746
-
Git.push_ref ~proc ~fs ~repo ~target ~ref_spec ()
898
+
Git_cli.push_ref ~proc ~fs ~repo ~target ~ref_spec ()
747
899
|> Result.map_error (fun e -> Git_error e)
748
900
| Git_checkout { repo; branch } ->
749
-
Git.checkout ~proc ~fs ~branch repo
901
+
Git_cli.checkout ~proc ~fs ~branch repo
750
902
|> Result.map_error (fun e -> Git_error e)
751
903
| Git_branch_rename { repo; new_name } ->
752
-
Git.branch_rename ~proc ~fs ~new_name repo
904
+
Git_cli.branch_rename ~proc ~fs ~new_name repo
753
905
|> Result.map_error (fun e -> Git_error e)
754
906
| Copy_directory { src; dest } ->
755
907
copy_directory ~fs ~src ~dest;
756
908
Ok ()
757
909
| Git_add_all path ->
758
-
Git.add_all ~proc ~fs path
759
-
|> Result.map_error (fun e -> Git_error e)
910
+
Git_cli.add_all ~proc ~fs path |> Result.map_error (fun e -> Git_error e)
760
911
| Git_commit { repo; message } ->
761
-
Git.commit ~proc ~fs ~message repo
912
+
Git_cli.commit ~proc ~fs ~message repo
762
913
|> Result.map_error (fun e -> Git_error e)
763
914
| Git_rm { repo; path; recursive } ->
764
-
Git.rm ~proc ~fs ~recursive repo path
915
+
Git_cli.rm ~proc ~fs ~recursive repo path
765
916
|> Result.map_error (fun e -> Git_error e)
766
-
| Update_sources_toml { path; name; entry } ->
917
+
| Update_sources_toml { path; name; entry } -> (
767
918
let sources =
768
919
match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) path with
769
920
| Ok s -> s
770
921
| Error _ -> Sources_registry.empty
771
922
in
772
923
let sources = Sources_registry.add sources ~subtree:name entry in
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)))
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
+
)
776
929
777
930
(** Execute a complete fork action plan *)
778
931
let execute_fork_plan ~proc ~fs plan =
779
-
if plan.dry_run then
780
-
Ok plan.result
932
+
if plan.dry_run then Ok plan.result
781
933
else begin
782
934
let state = { split_commit = None } in
783
935
let rec run_actions = function
784
936
| [] -> Ok ()
785
-
| action :: rest ->
937
+
| action :: rest -> (
786
938
match execute_action ~proc ~fs ~state action with
787
939
| Error e -> Error e
788
-
| Ok () -> run_actions rest
940
+
| Ok () -> run_actions rest)
789
941
in
790
942
match run_actions plan.actions with
791
943
| Error e -> Error e
···
801
953
802
954
(** Execute a complete join action plan *)
803
955
let execute_join_plan ~proc ~fs plan =
804
-
if plan.dry_run then
805
-
Ok plan.result
956
+
if plan.dry_run then Ok plan.result
806
957
else begin
807
958
let state = { split_commit = None } in
808
959
let rec run_actions = function
809
960
| [] -> Ok ()
810
-
| action :: rest ->
961
+
| action :: rest -> (
811
962
match execute_action ~proc ~fs ~state action with
812
963
| Error e -> Error e
813
-
| Ok () -> run_actions rest
964
+
| Ok () -> run_actions rest)
814
965
in
815
966
match run_actions plan.actions with
816
967
| Error e -> Error e
···
826
977
let subtree_path = Fpath.(monorepo / prefix) in
827
978
let src_path = Fpath.(checkouts / name) in
828
979
(* Validate: mono/<name>/ must exist *)
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)
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)
834
983
else begin
835
984
(* Find .opam files in subtree *)
836
985
let packages = find_opam_files ~fs subtree_path in
837
-
if packages = [] then
838
-
Error (No_opam_files name)
986
+
if packages = [] then Error (No_opam_files name)
839
987
else if dry_run then
840
-
Ok { name; split_commit = "(dry-run)"; src_path; push_url; packages_created = packages }
988
+
Ok
989
+
{
990
+
name;
991
+
split_commit = "(dry-run)";
992
+
src_path;
993
+
push_url;
994
+
packages_created = packages;
995
+
}
841
996
else begin
842
997
(* Split the subtree to get history *)
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
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
896
1085
| Ok () -> ()
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 }))
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
+
}))))))
900
1101
end
901
1102
end
902
1103
···
908
1109
let subtree_path = Fpath.(monorepo / prefix) in
909
1110
let src_path = Fpath.(checkouts / name) in
910
1111
(* Validate: mono/<name>/ must not exist *)
911
-
if Git.Subtree.exists ~fs ~repo:monorepo ~prefix then
1112
+
if Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix then
912
1113
Error (Subtree_already_exists name)
913
1114
else if dry_run then
914
-
Ok { name; source_url = url; upstream_url = upstream; packages_added = []; from_handle = None }
1115
+
Ok
1116
+
{
1117
+
name;
1118
+
source_url = url;
1119
+
upstream_url = upstream;
1120
+
packages_added = [];
1121
+
from_handle = None;
1122
+
}
915
1123
else begin
916
1124
(* Ensure src/ exists *)
917
1125
ensure_dir ~fs checkouts;
918
1126
(* Clone to src/<name>/ *)
919
1127
let branch = Verse_config.default_branch in
920
1128
let uri = Uri.of_string url in
921
-
match Git.clone ~proc ~fs ~url:uri ~branch src_path with
1129
+
match Git_cli.clone ~proc ~fs ~url:uri ~branch src_path with
922
1130
| Error e -> Error (Git_error e)
923
-
| Ok () ->
924
-
(* Add subtree to monorepo *)
925
-
match Git.Subtree.add ~proc ~fs ~repo:monorepo ~prefix ~url:uri ~branch () with
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
926
1136
| Error e -> Error (Git_error e)
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 }
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
+
}))
952
1202
end
953
1203
954
-
let join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url ?(dry_run = false) () =
1204
+
let join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url
1205
+
?(dry_run = false) () =
955
1206
(* First use verse fork to set up the opam entries *)
956
-
match Verse.fork ~proc ~fs ~config:verse_config ~handle ~package ~fork_url ~dry_run () with
1207
+
match
1208
+
Verse.fork ~proc ~fs ~config:verse_config ~handle ~package ~fork_url
1209
+
~dry_run ()
1210
+
with
957
1211
| Error e -> Error (Verse_error e)
958
1212
| Ok fork_result ->
959
1213
if dry_run then
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
-
}
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
+
}
967
1222
else begin
968
1223
(* Now join the repository *)
969
1224
let name = fork_result.subtree_name in
970
-
match join ~proc ~fs ~config ~url:fork_url ~name ~upstream:fork_result.upstream_url ~dry_run () with
1225
+
match
1226
+
join ~proc ~fs ~config ~url:fork_url ~name
1227
+
~upstream:fork_result.upstream_url ~dry_run ()
1228
+
with
971
1229
| Error e -> Error e
972
1230
| Ok join_result ->
973
-
Ok { join_result with
974
-
packages_added = fork_result.packages_forked;
975
-
from_handle = Some handle;
976
-
}
1231
+
Ok
1232
+
{
1233
+
join_result with
1234
+
packages_added = fork_result.packages_forked;
1235
+
from_handle = Some handle;
1236
+
}
977
1237
end
+78
-67
lib/fork_join.mli
+78
-67
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:
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 *)
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 *)
15
13
16
14
(** {1 Error Types} *)
17
15
18
16
type error =
19
17
| Config_error of string (** Configuration error *)
20
-
| Git_error of Git.error (** Git operation failed *)
18
+
| Git_error of Git_cli.error (** Git operation failed *)
21
19
| Subtree_not_found of string (** Subtree not found in monorepo *)
22
20
| Src_already_exists of string (** Source checkout already exists *)
23
21
| Src_not_found of string (** Source checkout not found *)
···
42
40
| Check_remote_exists of string (** URL - informational check *)
43
41
| Create_directory of Fpath.t
44
42
| Git_init of 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 }
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 }
54
59
| Git_add_all of Fpath.t
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 }
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
+
}
58
68
59
-
(** Discovery information gathered during planning *)
60
69
type discovery = {
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 *)
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 *)
67
76
}
77
+
(** Discovery information gathered during planning *)
68
78
69
-
(** A complete action plan *)
70
79
type 'a action_plan = {
71
-
discovery: discovery;
72
-
actions: action list;
73
-
result: 'a; (** What we'll return on success *)
74
-
dry_run: bool;
80
+
discovery : discovery;
81
+
actions : action list;
82
+
result : 'a; (** What we'll return on success *)
83
+
dry_run : bool;
75
84
}
85
+
(** A complete action plan *)
76
86
77
87
val pp_action : action Fmt.t
78
88
(** [pp_action] formats a single action. *)
···
89
99
(** [is_local_path s] returns true if [s] looks like a local filesystem path
90
100
rather than a URL. *)
91
101
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
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
95
106
be found and converted to SSH push format, [None] otherwise.
96
107
97
-
@param knot Optional git push server for tangled URLs (default: git.recoil.org) *)
108
+
@param knot
109
+
Optional git push server for tangled URLs (default: git.recoil.org) *)
98
110
99
111
(** {1 Result Types} *)
100
112
101
-
(** Result of a fork operation. *)
102
113
type fork_result = {
103
114
name : string; (** Subtree/repository name *)
104
115
split_commit : string; (** Git commit SHA from subtree split *)
···
106
117
push_url : string option; (** Remote push URL if provided *)
107
118
packages_created : string list; (** Package names from .opam files *)
108
119
}
120
+
(** Result of a fork operation. *)
109
121
110
122
val pp_fork_result : fork_result Fmt.t
111
123
(** [pp_fork_result] formats a fork result. *)
112
124
113
-
(** Result of a join operation. *)
114
125
type join_result = {
115
126
name : string; (** Subtree/repository name *)
116
127
source_url : string; (** URL the repository was cloned from *)
···
118
129
packages_added : string list; (** Package names from .opam files *)
119
130
from_handle : string option; (** Verse handle if joined from verse *)
120
131
}
132
+
(** Result of a join operation. *)
121
133
122
134
val pp_join_result : join_result Fmt.t
123
135
(** [pp_join_result] formats a join result. *)
···
133
145
?dry_run:bool ->
134
146
unit ->
135
147
(fork_result action_plan, error) result
136
-
(** [plan_fork ~proc ~fs ~config ~name ?push_url ?dry_run ()] builds a fork plan.
148
+
(** [plan_fork ~proc ~fs ~config ~name ?push_url ?dry_run ()] builds a fork
149
+
plan.
137
150
138
151
This analyzes the current state and builds a list of actions to:
139
152
- For subtrees with history: split subtree, create repo, push history
···
155
168
?dry_run:bool ->
156
169
unit ->
157
170
(join_result action_plan, error) result
158
-
(** [plan_join ~proc ~fs ~config ~source ?name ?upstream ?dry_run ()] builds a join plan.
171
+
(** [plan_join ~proc ~fs ~config ~source ?name ?upstream ?dry_run ()] builds a
172
+
join plan.
159
173
160
-
This analyzes the source (URL or local path) and builds a list of actions to:
174
+
This analyzes the source (URL or local path) and builds a list of actions
175
+
to:
161
176
- For URLs: clone repo, add subtree
162
177
- For local directories: copy/init repo, add subtree
163
178
164
179
The plan can be displayed to the user and executed with [execute_join_plan].
165
180
166
181
@param source Git URL or local filesystem path to join
167
-
@param name Override the subtree directory name (default: derived from source)
182
+
@param name
183
+
Override the subtree directory name (default: derived from source)
168
184
@param upstream Original upstream URL if this is your fork
169
185
@param dry_run If true, mark plan as dry-run (execute will skip actions) *)
170
186
···
178
194
(join_result action_plan, error) result
179
195
(** [plan_rejoin ~proc ~fs ~config ~name ?dry_run ()] builds a rejoin plan.
180
196
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.
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.
183
200
184
201
Requires:
185
202
- src/<name>/ must exist and be a git repository
···
199
216
(fork_result, error) result
200
217
(** [execute_fork_plan ~proc ~fs plan] executes a fork action plan.
201
218
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. *)
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. *)
205
222
206
223
val execute_join_plan :
207
224
proc:_ Eio.Process.mgr ->
···
227
244
(** [fork ~proc ~fs ~config ~name ?push_url ?dry_run ()] splits a monorepo
228
245
subtree into its own repository.
229
246
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
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
238
252
239
253
@param name Name of the subtree to fork (directory name under mono/)
240
254
@param push_url Optional remote URL to add as origin for pushing
···
255
269
(** [join ~proc ~fs ~config ~url ?name ?upstream ?dry_run ()] brings an external
256
270
repository into the monorepo.
257
271
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
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
265
276
266
277
@param url Git URL to clone from
267
278
@param name Override the subtree directory name (default: derived from URL)
268
-
@param upstream Original upstream URL if this is your fork of another project
279
+
@param upstream
280
+
Original upstream URL if this is your fork of another project
269
281
@param dry_run If true, validate and report what would be done *)
270
282
271
283
val join_from_verse :
···
282
294
(** [join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url
283
295
?dry_run ()] joins a package from a verse member's repository.
284
296
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
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
290
301
291
302
@param verse_config Verse configuration (for accessing verse/ directory)
292
303
@param package Package name to look up
+167
-53
lib/forks.ml
+167
-53
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 (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
-
| _ -> ())
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
+
| _ -> ())
48
50
pairs
49
51
end
50
52
with _ -> ()
···
60
62
ignore (Sys.command (Printf.sprintf "mkdir -p %s" (Filename.quote dir)));
61
63
(* Write cache as JSON *)
62
64
Out_channel.with_open_text path (fun oc ->
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")
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")
71
74
with _ -> ()
72
75
73
76
(** Check if a fetch is needed for a cache key *)
···
89
92
Hashtbl.replace fetch_cache key now;
90
93
save_cache ()
91
94
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
+
92
171
type repo_source = {
93
172
handle : string; (** Member handle or "me" *)
94
173
url : Uri.t; (** Normalized git URL *)
···
326
405
(* Generic git.<domain>: pattern - convert git@git.<domain>:path to https://git.<domain>/path *)
327
406
match String.index_opt s ':' with
328
407
| Some colon_pos ->
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
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
331
413
"https://" ^ host ^ "/" ^ path
332
414
| None -> s
333
415
else s
···
391
473
package_names
392
474
with _ -> []
393
475
394
-
(** Fetch a verse opam repo (with caching) *)
476
+
(** Fetch a verse opam repo (with caching). Returns true if actually fetched. *)
395
477
let fetch_verse_opam_repo ~proc ~fs ~refresh path =
396
478
let cache_key = "verse-opam/" ^ Fpath.to_string path in
397
479
if not (needs_fetch ~refresh ~timeout:default_cache_timeout cache_key) then begin
398
480
Log.debug (fun m -> m "Skipping fetch for %a (cached)" Fpath.pp path);
399
-
()
400
-
end else begin
481
+
false (* Did not fetch *)
482
+
end
483
+
else begin
401
484
let cwd = Eio.Path.(fs / Fpath.to_string path) in
402
-
let cmd = ["git"; "fetch"; "--quiet"] in
403
-
Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp path);
485
+
let cmd = [ "git"; "fetch"; "--quiet" ] in
486
+
Log.debug (fun m ->
487
+
m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp path);
404
488
Eio.Switch.run @@ fun sw ->
405
-
let child = Eio.Process.spawn proc ~sw ~cwd
489
+
let child =
490
+
Eio.Process.spawn proc ~sw ~cwd
406
491
~stdout:(Eio.Flow.buffer_sink (Buffer.create 16))
407
492
~stderr:(Eio.Flow.buffer_sink (Buffer.create 16))
408
493
cmd
409
494
in
410
495
match Eio.Process.await child with
411
-
| `Exited 0 -> record_fetch cache_key
412
-
| _ -> Log.debug (fun m -> m "Failed to fetch %a" Fpath.pp path)
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
413
502
end
414
503
415
-
(** Scan all verse opam repos and build a map: repo_basename -> [(handle, url, [packages])] *)
504
+
(** Scan all verse opam repos and build a map: repo_basename ->
505
+
[(handle, url, [packages])] *)
416
506
let scan_all_verse_opam_repos ~proc ~fs ~verse_path ~refresh () =
417
507
let eio_verse = Eio.Path.(fs / Fpath.to_string verse_path) in
418
508
let entries = try Eio.Path.read_dir eio_verse with _ -> [] in
419
509
(* Find opam repo directories (ending in -opam) *)
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) *)
510
+
let opam_dirs =
511
+
List.filter (fun name -> String.ends_with ~suffix:"-opam" name) entries
512
+
in
422
513
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;
427
514
(* Build map: repo_basename -> [(handle, url, [packages])] *)
428
515
let repo_map = Hashtbl.create 64 in
429
516
List.iter
···
431
518
let handle = String.sub opam_dir 0 (String.length opam_dir - 5) in
432
519
(* strip -opam *)
433
520
let opam_path = Fpath.(verse_path / opam_dir) in
434
-
let pkg_urls = scan_verse_opam_repo ~fs opam_path 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
435
536
(* Group by repo basename *)
436
537
let by_repo = Hashtbl.create 16 in
437
538
List.iter
···
510
611
511
612
(** Fetch a remote (with caching) *)
512
613
let fetch_remote ~proc ~fs ~repo ~remote ~refresh () =
513
-
let cache_key = Printf.sprintf "checkout/%s/%s" (Fpath.to_string repo) remote in
614
+
let cache_key =
615
+
Printf.sprintf "checkout/%s/%s" (Fpath.to_string repo) remote
616
+
in
514
617
if not (needs_fetch ~refresh ~timeout:default_cache_timeout cache_key) then 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
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
518
623
let cwd = Eio.Path.(fs / Fpath.to_string repo) in
519
-
let cmd = ["git"; "fetch"; remote] in
624
+
let cmd = [ "git"; "fetch"; remote ] in
520
625
Log.info (fun m -> m "Fetching %s in %a" remote Fpath.pp repo);
521
-
Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo);
626
+
Log.debug (fun m ->
627
+
m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo);
522
628
Eio.Switch.run @@ fun sw ->
523
-
let child = Eio.Process.spawn proc ~sw ~cwd
629
+
let child =
630
+
Eio.Process.spawn proc ~sw ~cwd
524
631
~stdout:(Eio.Flow.buffer_sink (Buffer.create 256))
525
632
~stderr:(Eio.Flow.buffer_sink (Buffer.create 256))
526
633
cmd
527
634
in
528
635
match Eio.Process.await child with
529
-
| `Exited 0 -> record_fetch cache_key; Ok ()
636
+
| `Exited 0 ->
637
+
record_fetch cache_key;
638
+
Ok ()
530
639
| _ -> Error "Failed to fetch remote"
531
640
end
532
641
···
623
732
Diverged { common_ancestor = base; my_ahead; their_ahead }))
624
733
625
734
(** Compute fork analysis for all repos *)
626
-
let compute ~proc ~fs ~verse_config ~monopam_config ?(refresh=false) () =
735
+
let compute ~proc ~fs ~verse_config ~monopam_config ?(refresh = false) () =
627
736
let verse_path = Verse_config.verse_path verse_config in
628
737
let opam_repo_path = Config.Paths.opam_repo monopam_config in
629
738
let checkouts_path = Config.Paths.checkouts monopam_config in
···
634
743
635
744
(* Scan verse opam repos *)
636
745
Log.info (fun m -> m "Scanning verse opam repos");
637
-
let verse_repos = scan_all_verse_opam_repos ~proc ~fs ~verse_path ~refresh () in
746
+
let verse_repos =
747
+
scan_all_verse_opam_repos ~proc ~fs ~verse_path ~refresh ()
748
+
in
638
749
639
750
(* Build combined list of all repo names *)
640
751
let all_repos = Hashtbl.create 64 in
···
660
771
else begin
661
772
(* Check if we have a local checkout *)
662
773
let checkout_path = Fpath.(checkouts_path / repo_name) in
663
-
let have_checkout = Git.is_repo ~proc ~fs checkout_path in
774
+
let have_checkout = Git_cli.is_repo ~proc ~fs checkout_path in
664
775
665
776
(* Process each verse source *)
666
777
let verse_with_rel =
···
687
798
~name:remote_name ~url:src.url ())
688
799
end;
689
800
(* Fetch remote (respecting cache unless refresh) *)
690
-
match fetch_remote ~proc ~fs ~repo:checkout_path ~remote:remote_name ~refresh () with
801
+
match
802
+
fetch_remote ~proc ~fs ~repo:checkout_path
803
+
~remote:remote_name ~refresh ()
804
+
with
691
805
| Error _ -> Not_fetched
692
806
| Ok () ->
693
807
(* Compare refs *)
+6
-8
lib/forks.mli
+6
-8
lib/forks.mli
···
76
76
?refresh:bool ->
77
77
unit ->
78
78
t
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
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
85
83
86
-
Fetches are cached for 1 hour by default. Use [~refresh:true] to force
87
-
fresh fetches from all remotes. *)
84
+
Fetches are cached for 1 hour by default. Use [~refresh:true] to force fresh
85
+
fetches from all remotes. *)
+110
-80
lib/git.ml
lib/git_cli.ml
+110
-80
lib/git.ml
lib/git_cli.ml
···
68
68
let retryable_error_patterns =
69
69
[
70
70
(* HTTP 5xx errors *)
71
-
"500"; "502"; "503"; "504"; "HTTP 5"; "http 5";
72
-
"Internal Server Error"; "Bad Gateway"; "Service Unavailable"; "Gateway Timeout";
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";
73
81
(* RPC failures (common git smart HTTP errors) *)
74
-
"RPC failed"; "curl"; "unexpected disconnect";
75
-
"the remote end hung up"; "early EOF";
82
+
"RPC failed";
83
+
"curl";
84
+
"unexpected disconnect";
85
+
"the remote end hung up";
86
+
"early EOF";
76
87
(* Connection errors *)
77
-
"Connection refused"; "Connection reset"; "Connection timed out";
78
-
"Could not resolve host"; "Failed to connect";
79
-
"Network is unreachable"; "Temporary failure";
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";
80
95
]
81
96
82
97
(** Check if an error is a retryable HTTP server error (5xx) or network error *)
83
98
let is_retryable_error result =
84
99
let stderr = result.stderr in
85
100
String.length stderr > 0
86
-
&& List.exists (fun needle -> string_contains ~needle stderr) retryable_error_patterns
101
+
&& List.exists
102
+
(fun needle -> string_contains ~needle stderr)
103
+
retryable_error_patterns
87
104
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 =
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 =
91
110
let rec attempt n delay_ms =
92
111
let result = run_git ~proc ~cwd args in
93
112
if result.exit_code = 0 then Ok result.stdout
94
113
else if n < max_retries && is_retryable_error result then begin
95
114
(* Log the retry *)
96
115
Logs.warn (fun m ->
97
-
m "Git command failed with retryable error, retrying in %dms (%d/%d): %s"
116
+
m
117
+
"Git command failed with retryable error, retrying in %dms \
118
+
(%d/%d): %s"
98
119
delay_ms (n + 1) max_retries result.stderr);
99
120
(* Sleep before retry - convert ms to seconds for Unix.sleepf *)
100
121
Unix.sleepf (float_of_int delay_ms /. 1000.0);
···
139
160
let cwd = Eio.Path.(fs / Fpath.to_string parent) in
140
161
let target_name = Fpath.basename target in
141
162
let url_str = Uri.to_string url in
142
-
run_git_ok_with_retry ~proc ~cwd [ "clone"; "--branch"; branch; url_str; target_name ]
163
+
run_git_ok_with_retry ~proc ~cwd
164
+
[ "clone"; "--branch"; branch; url_str; target_name ]
143
165
|> Result.map ignore
144
166
145
167
let fetch ~proc ~fs ?(remote = "origin") path =
···
202
224
Ok { ahead = int_of_string ahead; behind = int_of_string behind }
203
225
| _ -> Ok { ahead = 0; behind = 0 })
204
226
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
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))
212
239
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
221
-
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
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
239
245
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
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
246
252
247
253
let init ~proc ~fs path =
248
254
let cwd = path_to_eio ~fs (Fpath.parent path) in
···
261
267
| Some b -> b
262
268
| None -> Option.value ~default:"main" (current_branch ~proc ~fs path)
263
269
in
264
-
run_git_ok_with_retry ~proc ~cwd [ "push"; remote; branch ] |> Result.map ignore
270
+
run_git_ok_with_retry ~proc ~cwd [ "push"; remote; branch ]
271
+
|> Result.map ignore
265
272
266
273
let push_ref ~proc ~fs ~repo ~target ~ref_spec () =
267
274
let cwd = path_to_eio ~fs repo in
···
383
390
let cwd = path_to_eio ~fs repo_path in
384
391
run_git_ok ~proc ~cwd [ "show"; "--patch"; "--stat"; commit ]
385
392
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. *)
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. *)
390
397
let parse_subtree_message subject =
391
398
(* Helper to extract hex commit hash starting at position *)
392
399
let extract_hex s start =
···
471
478
(** {1 Worktree Operations} *)
472
479
473
480
module Worktree = struct
474
-
type entry = {
475
-
path : Fpath.t;
476
-
head : string;
477
-
branch : string option;
478
-
}
481
+
type entry = { path : Fpath.t; head : string; branch : string option }
479
482
480
483
let add ~proc ~fs ~repo ~path ~branch () =
481
484
let cwd = path_to_eio ~fs repo in
482
485
let path_str = Fpath.to_string path in
483
-
run_git_ok ~proc ~cwd
484
-
[ "worktree"; "add"; "-b"; branch; path_str ]
486
+
run_git_ok ~proc ~cwd [ "worktree"; "add"; "-b"; branch; path_str ]
485
487
|> Result.map ignore
486
488
487
489
let remove ~proc ~fs ~repo ~path ~force () =
···
506
508
HEAD abc123...
507
509
branch refs/heads/branchname (or detached) *)
508
510
let lines = String.split_on_char '\n' output in
509
-
let rec parse_entries acc current_path current_head current_branch = function
510
-
| [] ->
511
+
let rec parse_entries acc current_path current_head current_branch =
512
+
function
513
+
| [] -> (
511
514
(* Finalize last entry if we have one *)
512
-
(match current_path, current_head with
515
+
match (current_path, current_head) with
513
516
| Some p, Some h ->
514
-
let entry = { path = p; head = h; branch = current_branch } in
517
+
let entry =
518
+
{ path = p; head = h; branch = current_branch }
519
+
in
515
520
List.rev (entry :: acc)
516
521
| _ -> List.rev acc)
517
-
| "" :: rest ->
522
+
| "" :: rest -> (
518
523
(* End of entry block *)
519
-
(match current_path, current_head with
524
+
match (current_path, current_head) with
520
525
| Some p, Some h ->
521
-
let entry = { path = p; head = h; branch = current_branch } in
526
+
let entry =
527
+
{ path = p; head = h; branch = current_branch }
528
+
in
522
529
parse_entries (entry :: acc) None None None rest
523
530
| _ -> parse_entries acc None None None rest)
524
531
| line :: rest ->
525
532
if String.starts_with ~prefix:"worktree " line then
526
533
let path_str = String.sub line 9 (String.length line - 9) in
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)
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
530
541
else if String.starts_with ~prefix:"HEAD " line then
531
542
let head = String.sub line 5 (String.length line - 5) in
532
543
parse_entries acc current_path (Some head) current_branch rest
···
535
546
(* Extract branch name from refs/heads/... *)
536
547
let branch =
537
548
if String.starts_with ~prefix:"refs/heads/" branch_ref then
538
-
Some (String.sub branch_ref 11 (String.length branch_ref - 11))
539
-
else
540
-
Some branch_ref
549
+
Some
550
+
(String.sub branch_ref 11
551
+
(String.length branch_ref - 11))
552
+
else Some branch_ref
541
553
in
542
554
parse_entries acc current_path current_head branch rest
543
555
else if line = "detached" then
544
556
parse_entries acc current_path current_head None rest
545
557
else
546
-
parse_entries acc current_path current_head current_branch rest
558
+
parse_entries acc current_path current_head current_branch
559
+
rest
547
560
in
548
561
parse_entries [] None None None lines
549
562
···
556
569
let cwd = path_to_eio ~fs path in
557
570
run_git_ok ~proc ~cwd [ "cherry-pick"; commit ] |> Result.map ignore
558
571
559
-
let merge ~proc ~fs ~ref_name ?(ff_only=false) path =
572
+
let merge ~proc ~fs ~ref_name ?(ff_only = false) path =
560
573
let cwd = path_to_eio ~fs path in
561
-
let args = ["merge"] @ (if ff_only then ["--ff-only"] else []) @ [ref_name] in
574
+
let args =
575
+
[ "merge" ] @ (if ff_only then [ "--ff-only" ] else []) @ [ ref_name ]
576
+
in
562
577
run_git_ok ~proc ~cwd args |> Result.map ignore
563
578
564
579
(** {1 Diff Operations} *)
···
652
667
let branch_rename ~proc ~fs ~new_name path =
653
668
let cwd = path_to_eio ~fs path in
654
669
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)
+67
-85
lib/git.mli
lib/git_cli.mli
+67
-85
lib/git.mli
lib/git_cli.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
132
-
and resets the local branch to match the remote.
131
+
(** [fetch_and_reset ~proc ~fs ?remote ~branch path] fetches from the remote and
132
+
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 Operations} *)
171
-
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.
185
-
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 *)
190
-
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.
202
-
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 *)
170
+
(** {1 Subtree Helper Operations} *)
207
171
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.
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.
222
182
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 *)
183
+
@param repo Path to the local repository
184
+
@param url Git remote URL to fetch from
185
+
@param branch Branch to fetch *)
227
186
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.
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.
237
196
238
-
Returns the commit hash of the split branch head. *)
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") *)
239
200
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
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. *)
245
205
246
206
(** {1 Initialization} *)
247
207
···
490
450
491
451
(** Operations for git worktree management. *)
492
452
module Worktree : sig
493
-
(** A git worktree entry. *)
494
453
type entry = {
495
454
path : Fpath.t; (** Absolute path to the worktree *)
496
455
head : string; (** HEAD commit hash *)
497
456
branch : string option; (** Branch name if not detached *)
498
457
}
458
+
(** A git worktree entry. *)
499
459
500
460
val add :
501
461
proc:_ Eio.Process.mgr ->
···
539
499
repo:Fpath.t ->
540
500
path:Fpath.t ->
541
501
bool
542
-
(** [exists ~proc ~fs ~repo ~path] returns true if a worktree exists at [path]. *)
502
+
(** [exists ~proc ~fs ~repo ~path] returns true if a worktree exists at
503
+
[path]. *)
543
504
end
544
505
545
506
(** {1 Cherry-pick Operations} *)
···
550
511
commit:string ->
551
512
Fpath.t ->
552
513
(unit, error) result
553
-
(** [cherry_pick ~proc ~fs ~commit path] applies a single commit to the current branch.
514
+
(** [cherry_pick ~proc ~fs ~commit path] applies a single commit to the current
515
+
branch.
554
516
555
517
@param commit The commit hash to cherry-pick
556
518
@param path Path to the repository *)
···
562
524
?ff_only:bool ->
563
525
Fpath.t ->
564
526
(unit, error) result
565
-
(** [merge ~proc ~fs ~ref_name ?ff_only path] merges a ref into the current branch.
527
+
(** [merge ~proc ~fs ~ref_name ?ff_only path] merges a ref into the current
528
+
branch.
566
529
567
530
@param ref_name The ref to merge (e.g., "verse/handle/main")
568
531
@param ff_only If true, only allow fast-forward merges (default: false)
···
610
573
message:string ->
611
574
Fpath.t ->
612
575
(unit, error) result
613
-
(** [commit ~proc ~fs ~message path] creates a commit with the given message
614
-
in the repository at [path]. *)
576
+
(** [commit ~proc ~fs ~message path] creates a commit with the given message in
577
+
the repository at [path]. *)
615
578
616
579
val rm :
617
580
proc:_ Eio.Process.mgr ->
···
620
583
Fpath.t ->
621
584
string ->
622
585
(unit, error) result
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
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
625
588
recursively (git rm -r). *)
626
589
627
590
val config :
···
641
604
prefix:string ->
642
605
unit ->
643
606
bool
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. *)
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. *)
647
610
648
611
val branch_rename :
649
612
proc:_ Eio.Process.mgr ->
···
651
614
new_name:string ->
652
615
Fpath.t ->
653
616
(unit, error) result
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]. *)
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") *)
+1009
-687
lib/monopam.ml
+1009
-687
lib/monopam.ml
···
1
1
module Config = Config
2
2
module Package = Package
3
3
module Opam_repo = Opam_repo
4
-
module Git = Git
4
+
module Git_cli = Git_cli
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
19
20
20
21
let src = Logs.Src.create "monopam" ~doc:"Monopam operations"
21
22
22
23
module Log = (val Logs.src_log src : Logs.LOG)
23
24
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
+
24
33
type error =
25
34
| Config_error of string
26
35
| Repo_error of Opam_repo.error
27
-
| Git_error of Git.error
36
+
| Git_error of Git_cli.error
28
37
| Dirty_state of Package.t list
29
38
| Monorepo_dirty
30
39
| Package_not_found of string
···
33
42
let pp_error ppf = function
34
43
| Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
35
44
| Repo_error e -> Fmt.pf ppf "Repository error: %a" Opam_repo.pp_error e
36
-
| Git_error e -> Fmt.pf ppf "Git error: %a" Git.pp_error e
45
+
| Git_error e -> Fmt.pf ppf "Git error: %a" Git_cli.pp_error e
37
46
| Dirty_state pkgs ->
38
47
Fmt.pf ppf "Dirty packages: %a"
39
48
Fmt.(list ~sep:comma (using Package.name string))
···
46
55
*)
47
56
let error_hint = function
48
57
| Config_error _ ->
49
-
Some
50
-
"Run 'monopam init --handle <your-handle>' to create a workspace."
58
+
Some "Run 'monopam init --handle <your-handle>' to create a workspace."
51
59
| Repo_error (Opam_repo.No_dev_repo _) ->
52
60
Some
53
61
"Add a 'dev-repo' field to the package's opam file pointing to a git \
···
55
63
| Repo_error (Opam_repo.Not_git_remote _) ->
56
64
Some "The dev-repo must be a git URL (git+https:// or git://)."
57
65
| Repo_error _ -> None
58
-
| Git_error (Git.Dirty_worktree _) ->
66
+
| Git_error (Git_cli.Dirty_worktree _) ->
59
67
Some "Commit or stash your changes first: cd <repo> && git status"
60
-
| Git_error (Git.Not_a_repo _) ->
68
+
| Git_error (Git_cli.Not_a_repo _) ->
61
69
Some "Run 'monopam sync' to clone missing repositories."
62
-
| Git_error (Git.Subtree_prefix_missing _) ->
70
+
| Git_error (Git_cli.Subtree_prefix_missing _) ->
63
71
Some "Run 'monopam sync' to set up the subtree."
64
-
| Git_error (Git.Remote_not_found _) ->
72
+
| Git_error (Git_cli.Remote_not_found _) ->
65
73
Some "Check that the remote is configured: git remote -v"
66
-
| Git_error (Git.Branch_not_found _) ->
74
+
| Git_error (Git_cli.Branch_not_found _) ->
67
75
Some "Check available branches: git branch -a"
68
-
| Git_error (Git.Command_failed (cmd, _))
76
+
| Git_error (Git_cli.Command_failed (cmd, _))
69
77
when String.starts_with ~prefix:"git push" cmd ->
70
78
Some "Check your network connection and git credentials."
71
-
| Git_error (Git.Command_failed (cmd, _))
79
+
| Git_error (Git_cli.Command_failed (cmd, _))
72
80
when String.starts_with ~prefix:"git subtree" cmd ->
73
81
Some "Run 'monopam status' to check repository state."
74
82
| Git_error _ -> None
···
77
85
"Commit changes in the monorepo first: cd mono && git add -A && git \
78
86
commit"
79
87
| Monorepo_dirty ->
80
-
Some "Commit or stash your changes first: git status && git add -A && git commit"
88
+
Some
89
+
"Commit or stash your changes first: git status && git add -A && git \
90
+
commit"
81
91
| Package_not_found _ ->
82
92
Some "Check available packages: ls opam-repo/packages/"
83
93
| Claude_error msg when String.starts_with ~prefix:"Failed to decode" msg ->
···
136
146
let fs = fs_typed fs in
137
147
ensure_checkouts_dir ~fs ~config;
138
148
discover_packages ~fs:(fs :> _ Eio.Path.t) ~config ()
139
-
|> Result.map (Status.compute_all ~proc ~fs ~config)
149
+
|> Result.map (Status.compute_all ~fs ~config)
140
150
141
151
(** Find opam files in monorepo subtrees that aren't registered in the overlay.
142
152
Returns a list of (subtree_name, unregistered_package_name) pairs. *)
···
187
197
with Eio.Io _ -> [])
188
198
repos
189
199
190
-
(** Information about a package discovered from the monorepo. *)
191
200
type monorepo_package = {
192
201
pkg_name : string;
193
202
subtree : string;
···
195
204
url_src : string;
196
205
opam_content : string;
197
206
}
207
+
(** Information about a package discovered from the monorepo. *)
198
208
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) () =
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) () =
202
214
let fs = fs_typed fs in
203
215
let monorepo = Config.Paths.monorepo config in
204
216
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
···
215
227
with Eio.Io _ -> []
216
228
in
217
229
218
-
Log.debug (fun m -> m "Found %d subdirectories in monorepo" (List.length subdirs));
230
+
Log.debug (fun m ->
231
+
m "Found %d subdirectories in monorepo" (List.length subdirs));
219
232
220
233
(* Process each subdirectory *)
221
234
let packages, errors =
···
229
242
| `Regular_file -> (
230
243
(* Parse dune-project *)
231
244
let content =
232
-
try Some (Eio.Path.load dune_project_path)
233
-
with Eio.Io _ -> None
245
+
try Some (Eio.Path.load dune_project_path) with Eio.Io _ -> None
234
246
in
235
247
match content with
236
248
| None -> (pkgs, errs)
···
254
266
1. Explicit sources.toml entry for this subtree
255
267
2. dune-project source/homepage
256
268
3. sources.toml default_url_base + subtree name *)
257
-
let sources_override = Sources_registry.find sources ~subtree in
269
+
let sources_override =
270
+
Sources_registry.find sources ~subtree
271
+
in
258
272
259
273
let derive_from_dune () =
260
274
match
···
270
284
match Sources_registry.derive_url sources ~subtree with
271
285
| Some dev_repo ->
272
286
Log.debug (fun m ->
273
-
m "Using default_url_base for %s: %s" subtree dev_repo);
287
+
m "Using default_url_base for %s: %s" subtree
288
+
dev_repo);
274
289
Some (dev_repo, dev_repo ^ "#main")
275
290
| None -> None
276
291
in
···
286
301
| None -> (
287
302
(* Try to get branch from dune-project, default to main *)
288
303
match dune_proj.source with
289
-
| Some (Dune_project.Uri { branch = Some b; _ }) -> b
304
+
| Some (Dune_project.Uri { branch = Some b; _ })
305
+
->
306
+
b
290
307
| _ -> "main")
291
308
in
292
309
Log.debug (fun m ->
293
-
m "Using sources.toml entry for %s: %s" subtree dev_repo);
310
+
m "Using sources.toml entry for %s: %s" subtree
311
+
dev_repo);
294
312
Some (dev_repo, dev_repo ^ "#" ^ branch)
295
313
| None -> (
296
314
match derive_from_dune () with
···
300
318
| Some result -> Some result
301
319
| None ->
302
320
Log.warn (fun m ->
303
-
m "Cannot derive dev-repo for %s (no source in dune-project or sources.toml)" subtree);
321
+
m
322
+
"Cannot derive dev-repo for %s (no \
323
+
source in dune-project or \
324
+
sources.toml)"
325
+
subtree);
304
326
None))
305
327
in
306
328
match dev_repo_and_url with
307
329
| None -> (pkgs, "Cannot derive dev-repo" :: errs)
308
330
| Some (dev_repo, url_src) ->
309
331
Log.debug (fun m ->
310
-
m "Found %d opam files in %s" (List.length opam_files)
311
-
subtree);
332
+
m "Found %d opam files in %s"
333
+
(List.length opam_files) subtree);
312
334
(* Transform each opam file *)
313
335
let new_pkgs =
314
336
List.filter_map
···
326
348
~dev_repo ~url_src
327
349
in
328
350
Some
329
-
{ pkg_name; subtree; dev_repo; url_src; opam_content }
351
+
{
352
+
pkg_name;
353
+
subtree;
354
+
dev_repo;
355
+
url_src;
356
+
opam_content;
357
+
}
330
358
with Eio.Io _ -> None)
331
359
opam_files
332
360
in
···
335
363
(* No dune-project, skip *)
336
364
Log.debug (fun m -> m "No dune-project in %s, skipping" subtree);
337
365
(pkgs, errs)
338
-
| exception Eio.Io _ ->
339
-
(pkgs, errs))
366
+
| exception Eio.Io _ -> (pkgs, errs))
340
367
([], []) subdirs
341
368
in
342
369
···
367
394
Log.info (fun m ->
368
395
m "Cloning %s from %a (branch: %s)" (Package.repo_name pkg) Uri.pp
369
396
(Package.dev_repo pkg) branch);
370
-
Git.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir
397
+
Git_cli.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir
371
398
in
372
399
let is_directory =
373
400
match Eio.Path.kind ~follow:true checkout_eio with
···
376
403
| exception Eio.Io _ -> false
377
404
in
378
405
if not is_directory then do_clone ()
379
-
else if not (Git.is_repo ~proc ~fs checkout_dir) then do_clone ()
406
+
else if not (Git_cli.is_repo ~proc ~fs checkout_dir) then do_clone ()
380
407
else begin
381
408
Log.info (fun m -> m "Fetching %s" (Package.repo_name pkg));
382
-
match Git.fetch ~proc ~fs checkout_dir with
409
+
match Git_cli.fetch ~proc ~fs checkout_dir with
383
410
| Error e -> Error e
384
411
| Ok () ->
385
412
Log.info (fun m -> m "Updating %s to %s" (Package.repo_name pkg) branch);
386
-
Git.merge_ff ~proc ~fs ~branch checkout_dir
413
+
Git_cli.merge_ff ~proc ~fs ~branch checkout_dir
387
414
end
388
415
389
416
(* Group packages by their repository *)
···
657
684
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
658
685
let init_and_commit () =
659
686
Log.info (fun m -> m "Initializing monorepo at %a" Fpath.pp monorepo);
660
-
match Git.init ~proc ~fs monorepo with
687
+
match Git_cli.init ~proc ~fs monorepo with
661
688
| Error e -> Error (Git_error e)
662
689
| Ok () -> (
663
690
(* Create dune-project file so the monorepo builds *)
···
684
711
(* Commit *)
685
712
Log.debug (fun m -> m "Creating initial commit in monorepo");
686
713
match
687
-
Git.commit_allow_empty ~proc ~fs
714
+
Git_cli.commit_allow_empty ~proc ~fs
688
715
~message:
689
716
"Initial commit with dune-project, CLAUDE.md, and .gitignore"
690
717
monorepo
···
722
749
| _ -> false
723
750
| exception Eio.Io _ -> false
724
751
in
725
-
if is_directory && Git.is_repo ~proc ~fs monorepo then begin
752
+
if is_directory && Git_cli.is_repo ~proc ~fs monorepo then begin
726
753
Log.debug (fun m ->
727
754
m "Monorepo already initialized at %a" Fpath.pp monorepo);
728
755
ensure_file ~filename:"CLAUDE.md" ~content:claude_md_content;
···
805
832
806
833
(** Convert a clone URL to a push URL.
807
834
- GitHub HTTPS URLs are converted to SSH format
808
-
- Tangled URLs (tangled.org/tangled.sh) are converted to SSH format using the knot server
835
+
- Tangled URLs (tangled.org/tangled.sh) are converted to SSH format using
836
+
the knot server
809
837
- Other URLs are returned unchanged
810
-
@param knot Git push server hostname. Defaults to git.recoil.org if not provided. *)
838
+
839
+
@param knot
840
+
Git push server hostname. Defaults to git.recoil.org if not provided. *)
811
841
let url_to_push_url ?knot uri =
812
842
let scheme = Uri.scheme uri in
813
843
let host = Uri.host uri in
···
896
926
(* Pull from local checkout, not remote URL - ensures push/pull use same source *)
897
927
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
898
928
let url = Uri.of_string (Fpath.to_string checkout_dir) in
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
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
911
978
912
979
(* Check if checkout exists and is a repo *)
913
980
let checkout_exists ~proc ~fs ~config pkg =
···
915
982
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
916
983
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
917
984
match Eio.Path.kind ~follow:true checkout_eio with
918
-
| `Directory -> Git.is_repo ~proc ~fs checkout_dir
985
+
| `Directory -> Git_cli.is_repo ~proc ~fs checkout_dir
919
986
| _ -> false
920
987
| exception Eio.Io _ -> false
921
988
···
924
991
let checkouts_root = Config.Paths.checkouts config in
925
992
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
926
993
let branch = get_branch ~config pkg in
927
-
match Git.ahead_behind ~proc ~fs ~branch checkout_dir with
994
+
match Git_cli.ahead_behind ~proc ~fs ~branch checkout_dir with
928
995
| Ok ab -> ab.behind
929
996
| Error _ -> 0
930
997
···
932
999
let fs_t = fs_typed fs in
933
1000
(* Update the opam repo first - clone if needed *)
934
1001
let opam_repo = Config.Paths.opam_repo config in
935
-
if Git.is_repo ~proc ~fs:fs_t opam_repo then begin
1002
+
if Git_cli.is_repo ~proc ~fs:fs_t opam_repo then begin
936
1003
Log.info (fun m -> m "Updating opam repo at %a" Fpath.pp opam_repo);
937
1004
let result =
938
1005
let ( let* ) = Result.bind in
939
-
let* () = Git.fetch ~proc ~fs:fs_t opam_repo in
940
-
Git.merge_ff ~proc ~fs:fs_t opam_repo
1006
+
let* () = Git_cli.fetch ~proc ~fs:fs_t opam_repo in
1007
+
Git_cli.merge_ff ~proc ~fs:fs_t opam_repo
941
1008
in
942
1009
match result with
943
1010
| Ok () -> ()
944
1011
| Error e ->
945
-
Log.warn (fun m -> m "Failed to update opam repo: %a" Git.pp_error e)
1012
+
Log.warn (fun m ->
1013
+
m "Failed to update opam repo: %a" Git_cli.pp_error e)
946
1014
end
947
1015
else begin
948
1016
(* Opam repo doesn't exist - clone it if we have a URL *)
···
952
1020
m "Cloning opam repo from %s to %a" url Fpath.pp opam_repo);
953
1021
let url = Uri.of_string url in
954
1022
let branch = Config.default_branch in
955
-
match Git.clone ~proc ~fs:fs_t ~url ~branch opam_repo with
1023
+
match Git_cli.clone ~proc ~fs:fs_t ~url ~branch opam_repo with
956
1024
| Ok () -> Log.info (fun m -> m "Opam repo cloned successfully")
957
1025
| Error e ->
958
-
Log.warn (fun m -> m "Failed to clone opam repo: %a" Git.pp_error e)
959
-
)
1026
+
Log.warn (fun m ->
1027
+
m "Failed to clone opam repo: %a" Git_cli.pp_error e))
960
1028
| None ->
961
1029
Log.info (fun m ->
962
1030
m "Opam repo at %a does not exist and no URL provided" Fpath.pp
···
980
1048
else begin
981
1049
Log.info (fun m ->
982
1050
m "Checking status of %d packages" (List.length pkgs));
983
-
let statuses = Status.compute_all ~proc ~fs:fs_t ~config pkgs in
1051
+
let statuses = Status.compute_all ~fs:fs_t ~config pkgs in
984
1052
let dirty =
985
1053
List.filter Status.has_local_changes statuses
986
1054
|> List.map (fun s -> s.Status.package)
···
1112
1180
let checkouts_root = Config.Paths.checkouts config in
1113
1181
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
1114
1182
let branch = get_branch ~config pkg in
1115
-
if not (Git.Subtree.exists ~fs ~repo:monorepo ~prefix) then begin
1183
+
if not (Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix) then begin
1116
1184
Log.debug (fun m -> m "Subtree %s not in monorepo, skipping" prefix);
1117
1185
Ok ()
1118
1186
end
···
1121
1189
let needs_clone =
1122
1190
match Eio.Path.kind ~follow:true checkout_eio with
1123
1191
| exception Eio.Io _ -> true
1124
-
| `Directory when Git.is_repo ~proc ~fs checkout_dir -> false
1192
+
| `Directory when Git_cli.is_repo ~proc ~fs checkout_dir -> false
1125
1193
| _ -> true
1126
1194
in
1127
1195
let* () =
···
1131
1199
end
1132
1200
else Ok ()
1133
1201
in
1134
-
(* Use git subtree push to export commits to the checkout.
1202
+
(* Use native subtree split + push to export commits to the checkout.
1135
1203
This preserves commit identity, ensuring round-trips converge. *)
1136
1204
let checkout_url = Uri.of_string (Fpath.to_string checkout_dir) in
1137
1205
Log.info (fun m -> m "Subtree push %s -> %a" prefix Fpath.pp checkout_dir);
1138
-
let* () = Git.Subtree.push ~proc ~fs ~repo:monorepo ~prefix ~url:checkout_url ~branch () in
1139
-
Ok ()
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 ())
1140
1223
end
1141
1224
1142
1225
let push ~proc ~fs ~config ?package ?(upstream = false) () =
···
1156
1239
else begin
1157
1240
Log.info (fun m ->
1158
1241
m "Checking status of %d packages" (List.length pkgs));
1159
-
let statuses = Status.compute_all ~proc ~fs:fs_t ~config pkgs in
1242
+
let statuses = Status.compute_all ~fs:fs_t ~config pkgs in
1160
1243
let dirty =
1161
1244
List.filter Status.has_local_changes statuses
1162
1245
|> List.map (fun s -> s.Status.package)
···
1197
1280
m "Pushing %s to %s" (Package.repo_name pkg) push_url);
1198
1281
(* Set the push URL for origin *)
1199
1282
(match
1200
-
Git.set_push_url ~proc ~fs:fs_t ~url:push_url
1283
+
Git_cli.set_push_url ~proc ~fs:fs_t ~url:push_url
1201
1284
checkout_dir
1202
1285
with
1203
1286
| Ok () -> ()
1204
1287
| Error e ->
1205
1288
Log.warn (fun m ->
1206
-
m "Failed to set push URL: %a" Git.pp_error e));
1289
+
m "Failed to set push URL: %a" Git_cli.pp_error e));
1207
1290
match
1208
-
Git.push_remote ~proc ~fs:fs_t ~branch checkout_dir
1291
+
Git_cli.push_remote ~proc ~fs:fs_t ~branch checkout_dir
1209
1292
with
1210
1293
| Ok () ->
1211
1294
Log.app (fun m ->
···
1230
1313
type sync_failure = {
1231
1314
repo_name : string;
1232
1315
phase : sync_phase;
1233
-
error : Git.error;
1316
+
error : Git_cli.error;
1234
1317
}
1235
1318
1236
1319
type sync_summary = {
···
1249
1332
| `Push_remote -> Fmt.string ppf "push-remote"
1250
1333
1251
1334
let pp_sync_failure ppf f =
1252
-
Fmt.pf ppf "%s (%a): %a" f.repo_name pp_sync_phase f.phase Git.pp_error
1335
+
Fmt.pf ppf "%s (%a): %a" f.repo_name pp_sync_phase f.phase Git_cli.pp_error
1253
1336
f.error
1254
1337
1255
1338
let pp_sync_summary ppf s =
···
1272
1355
| _ -> false
1273
1356
| exception Eio.Io _ -> false
1274
1357
in
1275
-
let was_cloned = not (is_directory && Git.is_repo ~proc ~fs checkout_dir) in
1358
+
let was_cloned =
1359
+
not (is_directory && Git_cli.is_repo ~proc ~fs checkout_dir)
1360
+
in
1276
1361
if was_cloned then begin
1277
1362
Log.info (fun m ->
1278
1363
m "Cloning %s from %a (branch: %s)" (Package.repo_name pkg) Uri.pp
1279
1364
(Package.dev_repo pkg) branch);
1280
1365
match
1281
-
Git.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir
1366
+
Git_cli.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir
1282
1367
with
1283
1368
| Ok () ->
1284
1369
(* Configure checkout to accept pushes to current branch.
···
1287
1372
Eio.Switch.run (fun sw ->
1288
1373
let child =
1289
1374
Eio.Process.spawn proc ~sw ~cwd
1290
-
[ "git"; "config"; "receive.denyCurrentBranch"; "updateInstead" ]
1375
+
[
1376
+
"git"; "config"; "receive.denyCurrentBranch"; "updateInstead";
1377
+
]
1291
1378
in
1292
1379
ignore (Eio.Process.await child));
1293
1380
Ok (true, 0)
···
1306
1393
end
1307
1394
1308
1395
(* Fetch a single checkout - safe for parallel execution *)
1309
-
let fetch_checkout_safe ~proc ~fs ~config pkg =
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
1310
1426
let checkouts_root = Config.Paths.checkouts config in
1311
1427
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
1312
1428
let branch = get_branch ~config pkg in
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
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
1433
+
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
1318
1437
in
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
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)
1328
1449
in
1329
-
Ok (behind_after - behind_before)
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))
1330
1470
1331
1471
(* Merge checkout to latest - must be sequential *)
1332
1472
let merge_checkout_safe ~proc ~fs ~config pkg =
···
1334
1474
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
1335
1475
let branch = get_branch ~config pkg in
1336
1476
Log.info (fun m -> m "Merging %s to %s" (Package.repo_name pkg) branch);
1337
-
Git.merge_ff ~proc ~fs ~branch checkout_dir
1477
+
Git_cli.merge_ff ~proc ~fs ~branch checkout_dir
1338
1478
1339
1479
(* Push checkout to remote - safe for parallel execution *)
1340
1480
let push_remote_safe ~proc ~fs ~config pkg =
···
1344
1484
let push_url = url_to_push_url (Package.dev_repo pkg) in
1345
1485
Log.info (fun m -> m "Pushing %s to %s" (Package.repo_name pkg) push_url);
1346
1486
(* Set the push URL for origin *)
1347
-
(match Git.set_push_url ~proc ~fs ~url:push_url checkout_dir with
1487
+
(match Git_cli.set_push_url ~proc ~fs ~url:push_url checkout_dir with
1348
1488
| Ok () -> ()
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
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
1351
1492
1352
1493
(* Sanitize handle for use as git remote name *)
1353
1494
let sanitize_remote_name handle =
1354
1495
(* Replace @ and . with - for valid git remote names *)
1355
1496
String.map (function '@' | '.' -> '-' | c -> c) handle
1356
1497
1357
-
(* Ensure verse remotes for a single repo *)
1358
-
let ensure_verse_remotes_for_repo ~proc ~fs ~config ~verse_subtrees pkg =
1498
+
(* Ensure verse remotes for a single repo - fully native git *)
1499
+
let ensure_verse_remotes_for_repo ~fs ~config ~verse_subtrees pkg =
1359
1500
let checkouts_root = Config.Paths.checkouts config in
1360
1501
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
1502
+
let checkout_path = Fpath.to_string checkout_dir in
1361
1503
let repo_name = Package.repo_name pkg in
1362
1504
1363
-
(* Only process if checkout exists *)
1364
-
if not (Git.is_repo ~proc ~fs checkout_dir) then ()
1505
+
(* Only process if checkout exists - use native git *)
1506
+
if not (Git.Repository.is_repo ~fs checkout_path) then ()
1365
1507
else begin
1366
1508
(* Get all verse members who have this repo *)
1367
1509
let members_with_repo =
1368
1510
Hashtbl.find_opt verse_subtrees repo_name |> Option.value ~default:[]
1369
1511
in
1370
1512
1371
-
(* Get current remotes *)
1372
-
let current_remotes = Git.list_remotes ~proc ~fs checkout_dir in
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
1373
1516
let verse_remotes =
1374
1517
List.filter
1375
1518
(fun r -> String.starts_with ~prefix:"verse-" r)
1376
1519
current_remotes
1377
1520
in
1378
1521
1379
-
(* Build set of expected verse remotes *)
1522
+
(* Build set of expected verse remotes with their URLs *)
1380
1523
let expected_remotes =
1381
-
List.map
1382
-
(fun (handle, _) -> "verse-" ^ sanitize_remote_name handle)
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)
1383
1531
members_with_repo
1384
1532
in
1533
+
let expected_names = List.map fst expected_remotes in
1385
1534
1386
-
(* Add/update remotes for verse members *)
1535
+
(* Add/update remotes for verse members - native git *)
1387
1536
List.iter
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;
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;
1406
1546
1407
-
(* Remove outdated verse remotes *)
1547
+
(* Remove outdated verse remotes - native git *)
1408
1548
List.iter
1409
1549
(fun remote_name ->
1410
-
if not (List.mem remote_name expected_remotes) then begin
1550
+
if not (List.mem remote_name expected_names) then begin
1411
1551
Log.debug (fun m -> m "Removing outdated verse remote %s" remote_name);
1412
-
match Git.remove_remote ~proc ~fs ~name:remote_name checkout_dir with
1552
+
match Git.Repository.remove_remote repo remote_name with
1413
1553
| Ok () -> ()
1414
-
| Error e ->
1554
+
| Error (`Msg msg) ->
1415
1555
Log.warn (fun m ->
1416
-
m "Failed to remove verse remote %s: %a" remote_name
1417
-
Git.pp_error e)
1556
+
m "Failed to remove verse remote %s: %s" remote_name msg)
1418
1557
end)
1419
1558
verse_remotes
1420
1559
end
···
1426
1565
Verse.get_verse_subtrees ~proc ~fs ~config:verse_config ()
1427
1566
in
1428
1567
List.iter
1429
-
(fun pkg ->
1430
-
ensure_verse_remotes_for_repo ~proc ~fs ~config ~verse_subtrees pkg)
1568
+
(fun pkg -> ensure_verse_remotes_for_repo ~fs ~config ~verse_subtrees pkg)
1431
1569
repos
1432
1570
1433
-
(* Fetch from verse remotes for a repo *)
1571
+
(* Fetch from verse remotes for a repo - uses native git for list_remotes *)
1434
1572
let fetch_verse_remotes ~proc ~fs ~config pkg =
1435
1573
let checkouts_root = Config.Paths.checkouts config in
1436
1574
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
1437
-
let remotes = Git.list_remotes ~proc ~fs checkout_dir 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
1438
1582
let verse_remotes =
1439
1583
List.filter (fun r -> String.starts_with ~prefix:"verse-" r) remotes
1440
1584
in
1441
1585
List.iter
1442
1586
(fun remote ->
1443
1587
Log.debug (fun m -> m "Fetching from verse remote %s" remote);
1444
-
match Git.fetch ~proc ~fs ~remote checkout_dir with
1588
+
match Git_cli.fetch ~proc ~fs ~remote checkout_dir with
1445
1589
| Ok () -> ()
1446
1590
| Error e ->
1447
1591
Log.debug (fun m ->
1448
-
m "Failed to fetch from %s: %a" remote Git.pp_error e))
1592
+
m "Failed to fetch from %s: %a" remote Git_cli.pp_error e))
1449
1593
verse_remotes
1450
1594
1451
1595
(* Helper to read file contents, returning None if file doesn't exist *)
···
1469
1613
List.iter
1470
1614
(fun pkg ->
1471
1615
let pkg_dir =
1472
-
Fpath.(opam_repo / "packages" / pkg.pkg_name / (pkg.pkg_name ^ ".dev"))
1616
+
Fpath.(
1617
+
opam_repo / "packages" / pkg.pkg_name / (pkg.pkg_name ^ ".dev"))
1473
1618
in
1474
1619
let dst_path = Eio.Path.(fs / Fpath.to_string pkg_dir / "opam") in
1475
1620
let dst_content = read_file_opt dst_path in
···
1481
1626
end)
1482
1627
pkgs;
1483
1628
if !updated > 0 then
1484
-
Log.info (fun m -> m "Regenerated %d opam-repo entries from monorepo" !updated)
1629
+
Log.info (fun m ->
1630
+
m "Regenerated %d opam-repo entries from monorepo" !updated)
1485
1631
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. *)
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. *)
1488
1634
let clone_from_verse_if_needed ~proc ~fs ~config () =
1489
1635
let monorepo = Config.Paths.monorepo config in
1490
1636
let opam_repo = Config.Paths.opam_repo config 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
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
1493
1639
1494
1640
(* If both exist, nothing to do *)
1495
1641
if monorepo_exists && opam_repo_exists then Ok ()
···
1498
1644
match Verse_config.load ~fs () with
1499
1645
| Error _ ->
1500
1646
(* No verse config - can't clone from registry *)
1501
-
Log.debug (fun m -> m "No verse config found, will initialize fresh repos");
1647
+
Log.debug (fun m ->
1648
+
m "No verse config found, will initialize fresh repos");
1502
1649
Ok ()
1503
-
| Ok verse_config ->
1650
+
| Ok verse_config -> (
1504
1651
let handle = Verse_config.handle verse_config in
1505
1652
Log.info (fun m -> m "Found verse config for handle: %s" handle);
1506
1653
(* Load registry to look up URLs *)
1507
-
match Verse_registry.clone_or_pull ~proc ~fs ~config:verse_config () with
1654
+
match
1655
+
Verse_registry.clone_or_pull ~proc ~fs ~config:verse_config ()
1656
+
with
1508
1657
| Error msg ->
1509
1658
Log.warn (fun m -> m "Could not load verse registry: %s" msg);
1510
-
Ok () (* Continue without cloning - will init fresh *)
1511
-
| Ok registry ->
1659
+
Ok () (* Continue without cloning - will init fresh *)
1660
+
| Ok registry -> (
1512
1661
match Verse_registry.find_member registry ~handle with
1513
1662
| None ->
1514
1663
Log.warn (fun m -> m "Handle %s not found in registry" handle);
1515
1664
Ok ()
1516
-
| Some member ->
1665
+
| Some member -> (
1517
1666
(* Clone monorepo if needed *)
1518
1667
let result =
1519
1668
if monorepo_exists then Ok ()
1520
1669
else begin
1521
-
Log.app (fun m -> m "Cloning monorepo from %s..." member.monorepo);
1670
+
Log.app (fun m ->
1671
+
m "Cloning monorepo from %s..." member.monorepo);
1522
1672
let url = Uri.of_string member.monorepo in
1523
-
let branch = Option.value ~default:"main" member.monorepo_branch in
1524
-
match Git.clone ~proc ~fs ~url ~branch monorepo with
1673
+
let branch =
1674
+
Option.value ~default:"main" member.monorepo_branch
1675
+
in
1676
+
match Git_cli.clone ~proc ~fs ~url ~branch monorepo with
1525
1677
| Ok () ->
1526
1678
Log.app (fun m -> m "Monorepo cloned successfully");
1527
1679
Ok ()
1528
1680
| Error e ->
1529
-
Log.err (fun m -> m "Failed to clone monorepo: %a" Git.pp_error e);
1681
+
Log.err (fun m ->
1682
+
m "Failed to clone monorepo: %a" Git_cli.pp_error e);
1530
1683
Error (Git_error e)
1531
1684
end
1532
1685
in
···
1536
1689
(* Clone opam-repo if needed *)
1537
1690
if opam_repo_exists then Ok ()
1538
1691
else begin
1539
-
Log.app (fun m -> m "Cloning opam-repo from %s..." member.opamrepo);
1692
+
Log.app (fun m ->
1693
+
m "Cloning opam-repo from %s..." member.opamrepo);
1540
1694
let url = Uri.of_string member.opamrepo in
1541
-
let branch = Option.value ~default:"main" member.opamrepo_branch in
1542
-
match Git.clone ~proc ~fs ~url ~branch opam_repo with
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
1543
1699
| Ok () ->
1544
1700
Log.app (fun m -> m "Opam-repo cloned successfully");
1545
1701
Ok ()
1546
1702
| Error e ->
1547
-
Log.err (fun m -> m "Failed to clone opam-repo: %a" Git.pp_error e);
1703
+
Log.err (fun m ->
1704
+
m "Failed to clone opam-repo: %a" Git_cli.pp_error
1705
+
e);
1548
1706
Error (Git_error e)
1549
-
end
1707
+
end)))
1550
1708
1551
-
let sync ~proc ~fs ~config ?package ?(remote = false) ?(skip_push = false)
1552
-
?(skip_pull = false) () =
1709
+
let sync ~sw ~env ~proc ~fs ~config ~xdg ?package ?(remote = false)
1710
+
?(skip_push = false) ?(skip_pull = false) ?(skip_verse = false) () =
1553
1711
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
1554
1727
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));
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)));
1564
1741
1565
1742
(* Clone from verse registry if repos don't exist *)
1566
1743
match clone_from_verse_if_needed ~proc ~fs:fs_t ~config () with
1567
1744
| 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
1588
1745
| Ok () -> (
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
1599
-
| Error e -> Error e
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)
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
1616
1760
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
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
1770
+
| 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
1626
1788
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
1631
-
in
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
1647
-
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
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)
1657
1804
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
1678
-
in
1679
-
let skipped_ok =
1680
-
List.map (fun pkg -> Ok (Package.repo_name pkg)) to_skip
1681
-
in
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
1805
+
let repos = unique_repos pkgs in
1806
+
let total = List.length repos in
1807
+
Log.app (fun m -> m "Syncing %d repositories..." total);
1690
1808
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
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
1726
1814
in
1727
-
let fetch_errs, fetch_successes =
1728
-
List.partition_map
1729
-
(function Error e -> Left e | Ok r -> Right r)
1730
-
fetch_results
1731
-
in
1732
-
let cloned =
1733
-
List.filter (fun (_, c, _) -> c) fetch_successes
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
1734
1820
in
1735
-
let updated =
1736
-
List.filter
1737
-
(fun (_, c, commits) -> (not c) && commits > 0)
1738
-
fetch_successes
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)
1739
1825
in
1740
-
let unchanged =
1741
-
List.length fetch_successes
1742
-
- List.length cloned - List.length updated
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
1743
1831
in
1744
-
let commits_pulled =
1745
-
List.fold_left
1746
-
(fun acc (_, _, c) -> acc + c)
1747
-
0 fetch_successes
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)
1748
1836
in
1749
-
Log.app (fun m ->
1750
-
m " Pulled: %d cloned, %d updated, %d unchanged"
1751
-
(List.length cloned) (List.length updated) unchanged);
1752
1837
1753
-
(* Filter repos to only those that were successfully fetched *)
1754
-
let success_names =
1755
-
List.map (fun (name, _, _) -> name) fetch_successes
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
1756
1881
in
1757
-
let successfully_fetched =
1758
-
List.filter
1759
-
(fun pkg -> List.mem (Package.repo_name pkg) success_names)
1760
-
repos
1882
+
let push_errors =
1883
+
List.filter_map
1884
+
(function Error e -> Some e | Ok _ -> None)
1885
+
push_results
1761
1886
in
1762
1887
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;
1779
-
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");
1790
-
Log.app (fun m ->
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
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
1811
1896
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
1832
-
end;
1833
-
( fetch_errs,
1834
-
unchanged,
1835
-
commits_pulled,
1836
-
merge_errs,
1837
-
subtree_errs,
1838
-
successfully_fetched )
1839
-
end
1840
-
in
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);
1841
1967
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);
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
1853
1978
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;
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);
1860
2003
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
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
1878
2071
in
1879
-
let errors, successes =
1880
-
List.partition_map
1881
-
(function Error e -> Left e | Ok r -> Right r)
1882
-
push_results
2072
+
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));
2093
+
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
2100
+
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)
2108
+
end;
2109
+
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 []
1883
2142
in
1884
-
Log.app (fun m ->
1885
-
m " Pushed: %d repos to upstream" (List.length successes));
1886
-
errors
1887
-
end
1888
-
else []
1889
-
in
1890
2143
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
2144
+
(* Collect all errors *)
2145
+
let all_errors =
2146
+
push_errors @ fetch_errors @ !merge_errors @ !subtree_errors
2147
+
@ remote_errors
2148
+
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
+
}
2158
+
in
1906
2159
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;
2160
+
(* Print summary *)
2161
+
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;
1915
2168
1916
-
Ok summary
1917
-
end
1918
-
end
1919
-
end)
2169
+
Ok summary
2170
+
end
2171
+
end))
1920
2172
1921
2173
(* Opam metadata sync: copy .opam files from monorepo subtrees to opam-repo *)
1922
2174
···
1979
2231
| Ok s ->
1980
2232
let count = List.length (Sources_registry.to_list s) in
1981
2233
if count > 0 then
1982
-
Log.info (fun m -> m "Loaded %d source overrides from sources.toml" count);
2234
+
Log.info (fun m ->
2235
+
m "Loaded %d source overrides from sources.toml" count);
1983
2236
s
1984
2237
| Error msg ->
1985
2238
Log.warn (fun m -> m "Failed to load sources.toml: %s" msg);
···
1987
2240
in
1988
2241
1989
2242
(* Discover packages from monorepo *)
1990
-
match discover_packages_from_monorepo ~fs:(fs :> _ Eio.Path.t) ~config ~sources () with
2243
+
match
2244
+
discover_packages_from_monorepo ~fs:(fs :> _ Eio.Path.t) ~config ~sources ()
2245
+
with
1991
2246
| Error e -> Error e
1992
2247
| Ok all_pkgs ->
1993
2248
(* Filter to specific package/subtree if requested *)
···
2012
2267
(fun pkg ->
2013
2268
(* Destination: opam-repo/packages/<name>/<name>.dev/opam *)
2014
2269
let pkg_dir =
2015
-
Fpath.(opam_repo / "packages" / pkg.pkg_name / (pkg.pkg_name ^ ".dev"))
2270
+
Fpath.(
2271
+
opam_repo / "packages" / pkg.pkg_name / (pkg.pkg_name ^ ".dev"))
2016
2272
in
2017
2273
let dst_path = Eio.Path.(fs / Fpath.to_string pkg_dir / "opam") in
2018
2274
···
2043
2299
2044
2300
(* Find and delete orphaned packages *)
2045
2301
let generated_names =
2046
-
List.map (fun p -> p.pkg_name) pkgs
2047
-
|> List.sort_uniq String.compare
2302
+
List.map (fun p -> p.pkg_name) pkgs |> List.sort_uniq String.compare
2048
2303
in
2049
2304
let existing_packages = list_opam_repo_packages ~fs ~config in
2050
2305
let orphaned =
···
2070
2325
{
2071
2326
synced = List.rev !synced;
2072
2327
unchanged = List.rev !unchanged;
2073
-
missing = []; (* No longer used in generation-based approach *)
2328
+
missing = [];
2329
+
(* No longer used in generation-based approach *)
2074
2330
orphaned = deleted;
2075
2331
}
2076
2332
in
···
2124
2380
let fs = fs_typed fs in
2125
2381
let monorepo = Config.Paths.monorepo config in
2126
2382
let prefix = package in
2127
-
if not (Git.Subtree.exists ~fs ~repo:monorepo ~prefix) then Ok ()
2383
+
if not (Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix) then Ok ()
2128
2384
else
2129
2385
let subtree_path = Eio.Path.(fs / Fpath.to_string monorepo / prefix) in
2130
2386
try
2131
2387
Eio.Path.rmtree subtree_path;
2132
2388
Ok ()
2133
2389
with Eio.Io _ as e ->
2134
-
Error (Git_error (Git.Io_error (Printexc.to_string e)))
2390
+
Error (Git_error (Git_cli.Io_error (Printexc.to_string e)))
2135
2391
2136
2392
(* Changes command - generate weekly changelogs using Claude *)
2137
2393
···
2203
2459
let since = week_start ^ " 00:00:00" in
2204
2460
let until = week_end ^ " 23:59:59" in
2205
2461
match
2206
-
Git.log ~proc ~fs:fs_t ~since ~until ~path:repo_name
2207
-
monorepo
2462
+
Git_cli.log ~proc ~fs:fs_t ~since ~until
2463
+
~path:repo_name monorepo
2208
2464
with
2209
2465
| Error e -> Error (Git_error e)
2210
2466
| Ok commits ->
···
2246
2502
repo_name week_start);
2247
2503
(* Create new entry *)
2248
2504
let first_hash =
2249
-
(List.hd commits).Git.hash
2505
+
(List.hd commits).Git_cli.hash
2250
2506
in
2251
2507
let last_hash =
2252
-
(List.hd (List.rev commits)).Git.hash
2508
+
(List.hd (List.rev commits)).Git_cli.hash
2253
2509
in
2254
2510
let entry : Changes.weekly_entry =
2255
2511
{
···
2412
2668
let since = date ^ " 00:00:00" in
2413
2669
let until = date ^ " 23:59:59" in
2414
2670
match
2415
-
Git.log ~proc ~fs:fs_t ~since ~until ~path:repo_name
2416
-
monorepo
2671
+
Git_cli.log ~proc ~fs:fs_t ~since ~until
2672
+
~path:repo_name monorepo
2417
2673
with
2418
2674
| Error e -> Error (Git_error e)
2419
2675
| Ok commits ->
···
2456
2712
(* Extract unique contributors from commits *)
2457
2713
let contributors =
2458
2714
commits
2459
-
|> List.map (fun (c : Git.log_entry) ->
2460
-
c.author)
2715
+
|> List.map
2716
+
(fun (c : Git_cli.log_entry) ->
2717
+
c.author)
2461
2718
|> List.sort_uniq String.compare
2462
2719
in
2463
2720
(* Get repo URL from package dev_repo *)
···
2474
2731
in
2475
2732
(* Create new entry with hour and timestamp *)
2476
2733
let first_hash =
2477
-
(List.hd commits).Git.hash
2734
+
(List.hd commits).Git_cli.hash
2478
2735
in
2479
2736
let last_hash =
2480
-
(List.hd (List.rev commits)).Git.hash
2737
+
(List.hd (List.rev commits)).Git_cli.hash
2481
2738
in
2482
2739
let _, ((hour, _, _), _) =
2483
2740
Ptime.to_date_time now_ptime
···
2574
2831
if (not dry_run) && aggregate then begin
2575
2832
let today = Changes.date_of_ptime now_ptime in
2576
2833
let git_head =
2577
-
match Git.rev_parse ~proc ~fs:fs_t ~rev:"HEAD" monorepo with
2834
+
match Git_cli.rev_parse ~proc ~fs:fs_t ~rev:"HEAD" monorepo with
2578
2835
| Ok hash -> String.sub hash 0 (min 7 (String.length hash))
2579
2836
| Error _ -> "unknown"
2580
2837
in
···
2599
2856
repo_name : string;
2600
2857
handle : string;
2601
2858
relationship : Forks.relationship;
2602
-
commits : Git.log_entry list;
2603
-
patches : (string * string) list; (* hash -> patch content *)
2859
+
commits : Git_cli.log_entry list;
2860
+
patches : (string * string) list; (* hash -> patch content *)
2604
2861
}
2605
2862
2606
-
type diff_result = {
2607
-
entries : diff_entry list;
2608
-
forks : Forks.t;
2609
-
}
2863
+
type diff_result = { entries : diff_entry list; forks : Forks.t }
2610
2864
2611
2865
let pp_diff_entry ~show_patch ppf entry =
2612
2866
let n_commits = List.length entry.commits in
2613
2867
Fmt.pf ppf "@[<v 2>%a %s (%a, %d commit%s):@,"
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 -> ())
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 -> ())
2628
2884
entry.commits;
2629
2885
Fmt.pf ppf "@]"
2630
2886
···
2634
2890
(* Then show diffs for each entry *)
2635
2891
if result.entries <> [] then begin
2636
2892
Fmt.pf ppf "@[<v>%a@]@."
2637
-
Fmt.(list ~sep:(any "@,@,") (pp_diff_entry ~show_patch)) result.entries
2893
+
Fmt.(list ~sep:(any "@,@,") (pp_diff_entry ~show_patch))
2894
+
result.entries
2638
2895
end
2639
2896
2640
2897
(** Check if a string looks like a git commit hash (7+ hex chars) *)
2641
2898
let is_commit_sha s =
2642
-
String.length s >= 7 &&
2643
-
String.for_all (function '0'..'9' | 'a'..'f' | 'A'..'F' -> true | _ -> false) s
2899
+
String.length s >= 7
2900
+
&& String.for_all
2901
+
(function '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false)
2902
+
s
2644
2903
2645
-
let diff ~proc ~fs ~config ~verse_config ?repo ?(refresh=false) ?(patch=false) () =
2904
+
let diff ~proc ~fs ~config ~verse_config ?repo ?(refresh = false)
2905
+
?(patch = false) () =
2646
2906
let checkouts_path = Config.Paths.checkouts config in
2647
2907
2648
2908
(* Compute fork analysis *)
2649
-
let forks = Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh () in
2909
+
let forks =
2910
+
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
2911
+
in
2650
2912
2651
2913
(* Filter repos if specific one requested *)
2652
-
let repos_to_check = match repo with
2914
+
let repos_to_check =
2915
+
match repo with
2653
2916
| None -> forks.repos
2654
2917
| Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
2655
2918
in
2656
2919
2657
2920
(* For each repo with actionable status, get commits *)
2658
2921
let 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)
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))
2701
2981
repos_to_check
2702
2982
|> List.flatten
2703
2983
in
2704
2984
{ entries; forks }
2705
2985
2706
-
(** Result of looking up a specific commit *)
2707
2986
type commit_info = {
2708
2987
commit_repo : string;
2709
2988
commit_handle : string;
···
2712
2991
commit_author : string;
2713
2992
commit_patch : string;
2714
2993
}
2994
+
(** Result of looking up a specific commit *)
2715
2995
2716
2996
(** Show patch for a specific commit SHA from diff output *)
2717
-
let diff_show_commit ~proc ~fs ~config ~verse_config ~sha ?(refresh=false) () =
2997
+
let diff_show_commit ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) ()
2998
+
=
2718
2999
let checkouts_path = Config.Paths.checkouts config in
2719
3000
2720
3001
(* Compute fork analysis to find which repo has this commit *)
2721
-
let forks = Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh () in
3002
+
let forks =
3003
+
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
3004
+
in
2722
3005
2723
3006
(* Search through repos for this commit *)
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
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
2761
3059
in
2762
3060
result
2763
3061
···
2772
3070
let pp_handle_pull_result ppf result =
2773
3071
if result.repos_pulled <> [] then begin
2774
3072
Fmt.pf ppf "@[<v>%a@," Fmt.(styled `Bold string) "Pulled:";
2775
-
List.iter (fun (repo, count) ->
2776
-
Fmt.pf ppf " %s: %d commits@," repo count)
3073
+
List.iter
3074
+
(fun (repo, count) -> Fmt.pf ppf " %s: %d commits@," repo count)
2777
3075
result.repos_pulled;
2778
3076
Fmt.pf ppf "@]"
2779
3077
end;
2780
3078
if result.repos_skipped <> [] then
2781
3079
Fmt.pf ppf "%a %s@,"
2782
-
Fmt.(styled `Faint string) "Skipped:"
3080
+
Fmt.(styled `Faint string)
3081
+
"Skipped:"
2783
3082
(String.concat ", " result.repos_skipped);
2784
3083
if result.repos_failed <> [] then begin
2785
3084
Fmt.pf ppf "@[<v>%a@," Fmt.(styled `Red string) "Failed:";
2786
-
List.iter (fun (repo, err) ->
2787
-
Fmt.pf ppf " %s: %s@," repo err)
3085
+
List.iter
3086
+
(fun (repo, err) -> Fmt.pf ppf " %s: %s@," repo err)
2788
3087
result.repos_failed;
2789
3088
Fmt.pf ppf "@]"
2790
3089
end
2791
3090
2792
-
let pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo ?(refresh=false) () =
3091
+
let pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo
3092
+
?(refresh = false) () =
2793
3093
let checkouts_path = Config.Paths.checkouts config in
2794
3094
2795
3095
(* Compute fork analysis *)
2796
-
let forks = Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh () in
3096
+
let forks =
3097
+
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
3098
+
in
2797
3099
2798
3100
(* Filter repos if specific one requested *)
2799
-
let repos_to_check = match repo with
3101
+
let repos_to_check =
3102
+
match repo with
2800
3103
| None -> forks.repos
2801
3104
| Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
2802
3105
in
···
2806
3109
let repos_skipped = ref [] in
2807
3110
let repos_failed = ref [] in
2808
3111
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)
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)
2843
3157
repos_to_check;
2844
3158
2845
-
Ok {
2846
-
repos_pulled = List.rev !repos_pulled;
2847
-
repos_skipped = List.rev !repos_skipped;
2848
-
repos_failed = List.rev !repos_failed;
2849
-
}
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
+
}
2850
3165
2851
3166
(* ==================== Cherry-pick ==================== *)
2852
3167
···
2857
3172
}
2858
3173
2859
3174
let pp_cherrypick_result ppf result =
2860
-
let short_hash = String.sub result.commit_hash 0 (min 7 (String.length result.commit_hash)) in
3175
+
let short_hash =
3176
+
String.sub result.commit_hash 0 (min 7 (String.length result.commit_hash))
3177
+
in
2861
3178
Fmt.pf ppf "Cherry-picked %a %s into %s@."
2862
-
Fmt.(styled `Yellow string) short_hash
2863
-
result.commit_subject
2864
-
result.repo_name
3179
+
Fmt.(styled `Yellow string)
3180
+
short_hash result.commit_subject result.repo_name
2865
3181
2866
-
let cherrypick ~proc ~fs ~config ~verse_config ~sha ?(refresh=false) () =
3182
+
let cherrypick ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) () =
2867
3183
let checkouts_path = Config.Paths.checkouts config in
2868
3184
2869
3185
(* First, find the commit *)
2870
3186
match diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh () with
2871
3187
| None ->
2872
-
Error (Config_error (Printf.sprintf "Commit %s not found in any verse diff" sha))
3188
+
Error
3189
+
(Config_error
3190
+
(Printf.sprintf "Commit %s not found in any verse diff" sha))
2873
3191
| Some info ->
2874
3192
let checkout_path = Fpath.(checkouts_path / info.commit_repo) in
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))
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))
2877
3197
else begin
2878
-
match Git.cherry_pick ~proc ~fs ~commit:info.commit_hash checkout_path with
3198
+
match
3199
+
Git_cli.cherry_pick ~proc ~fs ~commit:info.commit_hash checkout_path
3200
+
with
2879
3201
| Ok () ->
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)
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)
2887
3209
end
+65
-52
lib/monopam.mli
+65
-52
lib/monopam.mli
···
17
17
- {!Config} - Configuration management
18
18
- {!Package} - Package metadata
19
19
- {!Opam_repo} - Opam repository scanning
20
-
- {!Git} - Git operations
20
+
- {!Git_cli} - Git operations (CLI-based)
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 = Git
28
+
module Git_cli = Git_cli
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
43
44
44
45
(** {1 High-Level Operations} *)
45
46
···
47
48
type error =
48
49
| Config_error of string (** Configuration error *)
49
50
| Repo_error of Opam_repo.error (** Opam repository error *)
50
-
| Git_error of Git.error (** Git operation error *)
51
+
| Git_error of Git_cli.error (** Git operation error *)
51
52
| Dirty_state of Package.t list
52
53
(** Operation blocked due to dirty packages *)
53
54
| Monorepo_dirty (** Monorepo has uncommitted changes *)
···
143
144
type sync_failure = {
144
145
repo_name : string;
145
146
phase : sync_phase;
146
-
error : Git.error;
147
+
error : Git_cli.error;
147
148
}
148
149
(** A failure during sync for a specific repository. *)
149
150
···
166
167
(** [pp_sync_summary] formats a sync summary. *)
167
168
168
169
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
+
; .. > ->
169
176
proc:_ Eio.Process.mgr ->
170
177
fs:Eio.Fs.dir_ty Eio.Path.t ->
171
178
config:Config.t ->
179
+
xdg:Xdge.t ->
172
180
?package:string ->
173
181
?remote:bool ->
174
182
?skip_push:bool ->
175
183
?skip_pull:bool ->
184
+
?skip_verse:bool ->
176
185
unit ->
177
186
(sync_summary, error) result
178
-
(** [sync ~proc ~fs ~config ?package ?remote ?skip_push ?skip_pull ()]
179
-
synchronizes the monorepo with upstream repositories.
187
+
(** [sync ~sw ~env ~proc ~fs ~config ~xdg ?package ?remote ?skip_push ?skip_pull
188
+
?skip_verse ()] synchronizes the monorepo with upstream repositories.
180
189
181
190
This is the primary command for all sync operations. It performs both push
182
191
and pull operations in the correct order: 1. Validate: check for dirty state
···
221
230
(** [sync_opam_files ~proc ~fs ~config ?package ()] generates opam-repo entries
222
231
from monorepo dune-project files.
223
232
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
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
232
240
233
241
This is a generation-based approach - opam-repo is derived entirely from
234
242
monorepo dune-project and .opam files.
···
312
320
@param config Monopam configuration
313
321
@param pkgs List of packages discovered from the opam overlay *)
314
322
315
-
(** Information about a package discovered from the monorepo. *)
316
323
type monorepo_package = {
317
324
pkg_name : string; (** Package name (from .opam filename) *)
318
325
subtree : string; (** Subtree directory name *)
···
320
327
url_src : string; (** url src with branch (e.g., "git+https://...#main") *)
321
328
opam_content : string; (** Transformed opam file content ready to write *)
322
329
}
330
+
(** Information about a package discovered from the monorepo. *)
323
331
324
332
val discover_packages_from_monorepo :
325
333
fs:Eio.Fs.dir_ty Eio.Path.t ->
···
330
338
(** [discover_packages_from_monorepo ~fs ~config ?sources ()] scans monorepo
331
339
subtrees and discovers packages from dune-project files.
332
340
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
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
337
345
338
346
@param fs Eio filesystem
339
347
@param config Monopam configuration
···
411
419
412
420
(** {1 Diff} *)
413
421
414
-
(** A diff entry for a single repository showing commits from a verse member. *)
415
422
type diff_entry = {
416
423
repo_name : string;
417
424
handle : string;
418
425
relationship : Forks.relationship;
419
-
commits : Git.log_entry list;
426
+
commits : Git_cli.log_entry list;
420
427
patches : (string * string) list; (** hash -> patch content *)
421
428
}
429
+
(** A diff entry for a single repository showing commits from a verse member. *)
422
430
431
+
type diff_result = { entries : diff_entry list; forks : Forks.t }
423
432
(** Result of computing diffs for repos needing attention. *)
424
-
type diff_result = {
425
-
entries : diff_entry list;
426
-
forks : Forks.t;
427
-
}
428
433
429
434
val pp_diff_entry : show_patch:bool -> diff_entry Fmt.t
430
-
(** [pp_diff_entry ~show_patch] formats a single diff entry.
431
-
If [show_patch] is true, includes the patch content for each commit. *)
435
+
(** [pp_diff_entry ~show_patch] formats a single diff entry. If [show_patch] is
436
+
true, includes the patch content for each commit. *)
432
437
433
438
val pp_diff_result : show_patch:bool -> diff_result Fmt.t
434
439
(** [pp_diff_result ~show_patch] formats the full diff result. *)
435
440
436
441
val is_commit_sha : string -> bool
437
-
(** [is_commit_sha s] returns true if [s] looks like a git commit hash
438
-
(7+ hexadecimal characters). *)
442
+
(** [is_commit_sha s] returns true if [s] looks like a git commit hash (7+
443
+
hexadecimal characters). *)
439
444
440
445
val diff :
441
446
proc:_ Eio.Process.mgr ->
···
447
452
?patch:bool ->
448
453
unit ->
449
454
diff_result
450
-
(** [diff ~proc ~fs ~config ~verse_config ?repo ?refresh ?patch ()] computes and displays diffs
451
-
for repositories that need attention from verse members.
455
+
(** [diff ~proc ~fs ~config ~verse_config ?repo ?refresh ?patch ()] computes and
456
+
displays diffs for repositories that need attention from verse members.
452
457
453
458
For each repository where a verse member is ahead (I_am_behind or Diverged),
454
459
retrieves the commit log showing what commits they have that you don't.
···
462
467
@param verse_config Verse configuration
463
468
@param repo Optional specific repository to show diff for
464
469
@param refresh If true, force fresh fetches ignoring cache (default: false)
465
-
@param patch If true, fetch and include patch content for each commit (default: false) *)
470
+
@param patch
471
+
If true, fetch and include patch content for each commit (default: false)
472
+
*)
466
473
467
-
(** Result of looking up a specific commit *)
468
474
type commit_info = {
469
475
commit_repo : string;
470
476
commit_handle : string;
···
473
479
commit_author : string;
474
480
commit_patch : string;
475
481
}
482
+
(** Result of looking up a specific commit *)
476
483
477
484
val diff_show_commit :
478
485
proc:_ Eio.Process.mgr ->
···
483
490
?refresh:bool ->
484
491
unit ->
485
492
commit_info option
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.
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.
488
495
489
496
Searches through all repos with actionable verse sources to find a commit
490
-
matching the given SHA prefix. Returns [Some commit_info] if found, [None] otherwise.
497
+
matching the given SHA prefix. Returns [Some commit_info] if found, [None]
498
+
otherwise.
491
499
492
500
@param sha Commit SHA prefix (7+ characters) to look up *)
493
501
494
502
(** {1 Pull from Verse Members} *)
495
503
496
-
(** Result of pulling from a handle. *)
497
504
type handle_pull_result = {
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 *)
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 *)
501
511
}
512
+
(** Result of pulling from a handle. *)
502
513
503
514
val pp_handle_pull_result : handle_pull_result Fmt.t
504
515
(** [pp_handle_pull_result] formats a pull result. *)
···
516
527
(** [pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo ?refresh ()]
517
528
pulls commits from a verse member's forks into your local checkouts.
518
529
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]
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]
522
533
523
-
If [repo] is specified, only pulls from that repository.
524
-
Otherwise, pulls from all repositories where the handle is ahead.
534
+
If [repo] is specified, only pulls from that repository. Otherwise, pulls
535
+
from all repositories where the handle is ahead.
525
536
526
537
@param handle The verse member handle (e.g., "avsm.bsky.social")
527
538
@param repo Optional specific repository to pull from
528
-
@param refresh If true, force fresh fetches ignoring cache (default: false) *)
539
+
@param refresh If true, force fresh fetches ignoring cache (default: false)
540
+
*)
529
541
530
542
(** {1 Cherry-pick} *)
531
543
532
-
(** Result of cherry-picking a commit. *)
533
544
type cherrypick_result = {
534
545
repo_name : string;
535
546
commit_hash : string;
536
547
commit_subject : string;
537
548
}
549
+
(** Result of cherry-picking a commit. *)
538
550
539
551
val pp_cherrypick_result : cherrypick_result Fmt.t
540
552
(** [pp_cherrypick_result] formats a cherry-pick result. *)
···
548
560
?refresh:bool ->
549
561
unit ->
550
562
(cherrypick_result, error) result
551
-
(** [cherrypick ~proc ~fs ~config ~verse_config ~sha ?refresh ()]
552
-
applies a specific commit from a verse member's fork to your local checkout.
563
+
(** [cherrypick ~proc ~fs ~config ~verse_config ~sha ?refresh ()] applies a
564
+
specific commit from a verse member's fork to your local checkout.
553
565
554
566
Finds the commit in the verse diff output and cherry-picks it into the
555
-
appropriate local checkout. The changes are then ready to be synced to
556
-
the monorepo via [sync].
567
+
appropriate local checkout. The changes are then ready to be synced to the
568
+
monorepo via [sync].
557
569
558
570
@param sha Commit SHA prefix (7+ characters) to cherry-pick
559
-
@param refresh If true, force fresh fetches ignoring cache (default: false) *)
571
+
@param refresh If true, force fresh fetches ignoring cache (default: false)
572
+
*)
+16
-9
lib/opam_repo.ml
+16
-9
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) with Eio.Io _ as e -> Error (Io_error (Printexc.to_string e))
191
+
try Ok (Eio.Path.load eio_path)
192
+
with Eio.Io _ as e -> Error (Io_error (Printexc.to_string e))
192
193
193
-
(** Replace dev-repo line in content. Looks for 'dev-repo: "..."' and replaces the URL. *)
194
+
(** Replace dev-repo line in content. Looks for 'dev-repo: "..."' and replaces
195
+
the URL. *)
194
196
let replace_dev_repo_line content ~new_url =
195
197
let lines = String.split_on_char '\n' content in
196
198
let dev_repo_url =
···
215
217
let url_src =
216
218
let base =
217
219
if String.starts_with ~prefix:"git@" new_url then "git+" ^ new_url
218
-
else if String.starts_with ~prefix:"https://" new_url then "git+" ^ new_url
220
+
else if String.starts_with ~prefix:"https://" new_url then
221
+
"git+" ^ new_url
219
222
else if String.starts_with ~prefix:"git+" new_url then new_url
220
223
else "git+" ^ new_url
221
224
in
···
239
242
else
240
243
(* Skip this line, it's part of the old url block *)
241
244
process rest true acc
242
-
else if trimmed = "url {" || String.starts_with ~prefix:"url {" trimmed then
245
+
else if trimmed = "url {" || String.starts_with ~prefix:"url {" trimmed
246
+
then
243
247
(* Start of url block *)
244
248
if String.ends_with ~suffix:"}" trimmed then
245
249
(* Single-line url block *)
···
252
256
in
253
257
String.concat "\n" (process lines false [])
254
258
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"). *)
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"). *)
257
262
let replace_dev_repo_url content ~new_url =
258
263
let content = replace_dev_repo_line content ~new_url in
259
264
let content = replace_url_section content ~new_url in
260
265
content
261
266
262
-
(** Write an opam package to the opam-repo overlay.
263
-
Creates the directory structure: packages/<name>/<name.version>/opam *)
267
+
(** Write an opam package to the opam-repo overlay. Creates the directory
268
+
structure: packages/<name>/<name.version>/opam *)
264
269
let write_package ~fs ~repo_path ~name ~version ~content =
265
-
let pkg_dir = Fpath.(repo_path / "packages" / name / (name ^ "." ^ version)) in
270
+
let pkg_dir =
271
+
Fpath.(repo_path / "packages" / name / (name ^ "." ^ version))
272
+
in
266
273
let opam_path = Fpath.(pkg_dir / "opam") in
267
274
let eio_pkg_dir = Eio.Path.(fs / Fpath.to_string pkg_dir) in
268
275
let eio_opam_path = Eio.Path.(fs / Fpath.to_string opam_path) in
+8
-5
lib/opam_repo.mli
+8
-5
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 items. *)
93
+
(** [find_dev_repo items] extracts the dev-repo field from parsed opam file
94
+
items. *)
94
95
95
96
(** {1 Writing Packages} *)
96
97
···
100
101
val replace_dev_repo_url : string -> new_url:string -> string
101
102
(** [replace_dev_repo_url content ~new_url] replaces the dev-repo and url fields
102
103
in an opam file content with a new git URL. The new URL should be a plain
103
-
git URL (e.g., "git@github.com:user/repo.git" or "https://github.com/user/repo.git"). *)
104
+
git URL (e.g., "git@github.com:user/repo.git" or
105
+
"https://github.com/user/repo.git"). *)
104
106
105
107
val write_package :
106
108
fs:_ Eio.Path.t ->
···
109
111
version:string ->
110
112
content:string ->
111
113
(unit, error) result
112
-
(** [write_package ~fs ~repo_path ~name ~version ~content] writes an opam package
113
-
to the opam-repo overlay.
114
+
(** [write_package ~fs ~repo_path ~name ~version ~content] writes an opam
115
+
package to the opam-repo overlay.
114
116
115
117
Creates the directory structure: [packages/<name>/<name.version>/opam] *)
116
118
117
119
val package_exists : fs:_ Eio.Path.t -> repo_path:Fpath.t -> name:string -> bool
118
-
(** [package_exists ~fs ~repo_path ~name] checks if a package exists in the opam-repo. *)
120
+
(** [package_exists ~fs ~repo_path ~name] checks if a package exists in the
121
+
opam-repo. *)
+2
-5
lib/opam_transform.ml
+2
-5
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
36
-
process rest false acc
35
+
if String.starts_with ~prefix:"}" trimmed then process rest false acc
37
36
else process rest true acc
38
37
else if trimmed = "url {" || String.starts_with ~prefix:"url {" trimmed
39
38
then
···
72
71
73
72
(* Step 4: Append dev-repo and url section *)
74
73
let dev_repo_line = Printf.sprintf {|dev-repo: "%s"|} dev_repo in
75
-
let url_section =
76
-
Printf.sprintf "url {\n src: \"%s\"\n}" url_src
77
-
in
74
+
let url_section = Printf.sprintf "url {\n src: \"%s\"\n}" url_src in
78
75
content ^ "\n" ^ dev_repo_line ^ "\n" ^ url_section ^ "\n"
+4
-2
lib/opam_transform.mli
+4
-2
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 file.
10
+
(** [transform ~content ~dev_repo ~url_src] transforms a dune-generated opam
11
+
file.
11
12
12
13
- Removes the "# This file is generated by dune" comment if present
13
14
- Adds or replaces the [dev-repo] field with [dev_repo]
14
15
- Adds or replaces the [url { src: "..." }] section with [url_src]
15
16
16
17
@param content The original opam file content
17
-
@param dev_repo The dev-repo URL (e.g., "git+https://github.com/user/repo.git")
18
+
@param dev_repo
19
+
The dev-repo URL (e.g., "git+https://github.com/user/repo.git")
18
20
@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. *)
+361
-240
lib/site.ml
+361
-240
lib/site.ml
···
1
1
(** Generate a static HTML site representing the monoverse map. *)
2
2
3
-
(** Information about a package in the verse *)
4
3
type pkg_info = {
5
4
name : string;
6
5
synopsis : string option;
···
9
8
owners : string list; (** List of handles that have this package *)
10
9
depends : string list; (** Package dependencies *)
11
10
}
11
+
(** Information about a package in the verse *)
12
12
13
-
(** Information about a repository (group of packages) *)
14
13
type repo_info = {
15
14
ri_name : string;
16
15
ri_dev_repo : string;
17
16
ri_packages : pkg_info list;
18
-
ri_owners : string list; (** All handles that have any package from this repo *)
19
-
ri_fork_status : (string * Forks.relationship) list; (** (handle, relationship) *)
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) *)
20
21
ri_dep_count : int; (** Number of dependencies (for sorting) *)
21
22
}
23
+
(** Information about a repository (group of packages) *)
22
24
23
-
(** Information about a verse member *)
24
25
type member_info = {
25
26
handle : string;
26
27
display_name : string; (** Name to display (from registry or handle) *)
···
29
30
package_count : int;
30
31
unique_packages : string list; (** Packages unique to this member *)
31
32
}
33
+
(** Information about a verse member *)
32
34
33
-
(** Aggregated site data *)
34
35
type site_data = {
35
36
local_handle : string;
36
37
registry_name : string;
···
40
41
unique_repos : repo_info list; (** Repos unique to one member *)
41
42
all_packages : pkg_info list; (** All packages *)
42
43
}
44
+
(** Aggregated site data *)
43
45
44
46
(** Scan a member's opam repo and return package info *)
45
47
let scan_member_packages ~fs opam_repo_path =
46
48
let pkgs, _errors = Opam_repo.scan_all ~fs opam_repo_path in
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
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
57
60
58
61
(** Check if a directory exists *)
59
62
let dir_exists ~fs path =
···
77
80
in
78
81
79
82
(* Build a map: package name -> list of (handle, pkg_info) *)
80
-
let pkg_map : (string, (string * pkg_info) list) Hashtbl.t = Hashtbl.create 256 in
83
+
let pkg_map : (string, (string * pkg_info) list) Hashtbl.t =
84
+
Hashtbl.create 256
85
+
in
81
86
82
87
(* Add local packages *)
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;
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;
87
93
88
94
let registry_name = registry.Verse_registry.name in
89
95
let registry_description = registry.Verse_registry.description in
90
96
91
97
(* Build handle -> display name lookup *)
92
98
let handle_to_name = Hashtbl.create 16 in
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;
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;
97
104
98
105
(* Get tracked handles from verse directory, excluding local handle *)
99
106
let tracked_handles =
···
102
109
try
103
110
Eio.Path.read_dir eio_path
104
111
|> List.filter (fun name ->
105
-
not (String.ends_with ~suffix:"-opam" name) &&
106
-
name <> local_handle &&
107
-
dir_exists ~fs Fpath.(verse_path / name))
112
+
(not (String.ends_with ~suffix:"-opam" name))
113
+
&& name <> local_handle
114
+
&& dir_exists ~fs Fpath.(verse_path / name))
108
115
with Eio.Io _ -> []
109
116
else []
110
117
in
111
118
112
119
(* Scan each tracked member's opam repo *)
113
120
let member_infos =
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
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
139
153
in
140
154
141
155
(* Add local member info *)
···
157
171
158
172
(* Build final package list with owners *)
159
173
let all_packages =
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 []
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 []
176
189
|> List.sort (fun a b -> String.compare a.name b.name)
177
190
in
178
191
179
192
(* Build set of all package names for dependency counting *)
180
193
let all_pkg_names =
181
-
List.fold_left (fun s p -> Hashtbl.replace s p.name (); s)
194
+
List.fold_left
195
+
(fun s p ->
196
+
Hashtbl.replace s p.name ();
197
+
s)
182
198
(Hashtbl.create 256) all_packages
183
199
in
184
200
185
201
(* Group packages by repo *)
186
202
let repos_map : (string, pkg_info list) Hashtbl.t = Hashtbl.create 64 in
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;
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;
191
210
192
211
(* Build forks status lookup from forks data if provided *)
193
-
let forks_by_repo : (string, (string * Forks.relationship) list) Hashtbl.t = Hashtbl.create 64 in
212
+
let forks_by_repo : (string, (string * Forks.relationship) list) Hashtbl.t =
213
+
Hashtbl.create 64
214
+
in
194
215
(match forks with
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 -> ());
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 -> ());
201
225
202
226
(* Build repo_info list with dependency counts *)
203
227
let all_repos =
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 []
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 []
226
255
(* Sort by dependency count descending (apps with most deps first), then by name *)
227
256
|> List.sort (fun a b ->
228
257
let cmp = compare b.ri_dep_count a.ri_dep_count in
···
230
259
in
231
260
232
261
(* Separate common and unique repos *)
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
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
235
268
236
269
(* Compute unique packages per member *)
237
270
let unique_by_handle = Hashtbl.create 32 in
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;
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;
245
281
246
282
(* Update member infos with unique packages *)
247
283
let update_member m =
248
-
let unique = try Hashtbl.find unique_by_handle m.handle with Not_found -> [] in
284
+
let unique =
285
+
try Hashtbl.find unique_by_handle m.handle with Not_found -> []
286
+
in
249
287
{ m with unique_packages = List.sort String.compare unique }
250
288
in
251
289
252
290
let all_members = local_member :: member_infos in
253
291
let members = List.map update_member all_members in
254
292
255
-
{ local_handle; registry_name; registry_description; members; common_repos; unique_repos; all_packages }
293
+
{
294
+
local_handle;
295
+
registry_name;
296
+
registry_description;
297
+
members;
298
+
common_repos;
299
+
unique_repos;
300
+
all_packages;
301
+
}
256
302
257
303
(** Escape HTML special characters *)
258
304
let html_escape s =
259
305
let buf = Buffer.create (String.length s) in
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;
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;
267
314
Buffer.contents buf
268
315
269
316
(** External link SVG icon *)
···
276
323
| Forks.Same_commit -> "sync"
277
324
| Forks.I_am_ahead n -> Printf.sprintf "+%d" n
278
325
| Forks.I_am_behind n -> Printf.sprintf "-%d" n
279
-
| Forks.Diverged { my_ahead; their_ahead; _ } -> Printf.sprintf "+%d/-%d" my_ahead their_ahead
326
+
| Forks.Diverged { my_ahead; their_ahead; _ } ->
327
+
Printf.sprintf "+%d/-%d" my_ahead their_ahead
280
328
| Forks.Unrelated -> "unrel"
281
329
| Forks.Not_fetched -> "?"
282
330
···
288
336
(* Build member lookups *)
289
337
let member_urls = Hashtbl.create 16 in
290
338
let member_names = Hashtbl.create 16 in
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;
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;
295
344
296
345
(* Helper to get display name for handle *)
297
346
let get_name handle =
298
347
try Hashtbl.find member_names handle with Not_found -> handle
299
348
in
300
349
301
-
add {|<!DOCTYPE html>
350
+
add
351
+
{|<!DOCTYPE html>
302
352
<html lang="en">
303
353
<head>
304
354
<meta charset="UTF-8">
305
355
<meta name="viewport" content="width=device-width, initial-scale=1.0">
306
356
<title>|};
307
357
add (html_escape data.registry_name);
308
-
add {|</title>
358
+
add
359
+
{|</title>
309
360
<style>
310
361
* { margin: 0; padding: 0; box-sizing: border-box; }
311
362
body { font: 10pt/1.4 -apple-system, BlinkMacSystemFont, "Segoe UI", Roboto, sans-serif; color: #333; max-width: 900px; margin: 0 auto; padding: 12px; }
···
365
416
(* Title and description *)
366
417
add (Printf.sprintf "<h1>%s</h1>\n" (html_escape data.registry_name));
367
418
(match data.registry_description with
368
-
| Some desc -> add (Printf.sprintf "<div class=\"subtitle\">%s</div>\n" (html_escape desc))
369
-
| None -> add "<div class=\"subtitle\"></div>\n");
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");
370
423
371
424
(* Intro section *)
372
-
add {|<div class="intro">
425
+
add
426
+
{|<div class="intro">
373
427
This is an experiment in large-scale agentic coding using OCaml and OxCaml, where we're building environments to exchange vibe code at scale.
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>.
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>.
376
435
</div>
377
436
|};
378
437
379
438
(* Members section *)
380
439
add "<div class=\"section\">\n<h2>Members</h2>\n<div class=\"members\">\n";
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;
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;
401
473
add "</div>\n</div>\n";
402
474
403
475
(* Summary section *)
404
476
add "<div class=\"section\">\n";
405
477
add "<div class=\"summary\">\n";
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));
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));
409
486
add "<div class=\"summary-list\">\n";
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;
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;
414
496
add "</div>\n</div>\n";
415
497
416
498
(* Member-specific summary *)
417
-
let members_with_unique = List.filter (fun m -> m.unique_packages <> []) data.members in
499
+
let members_with_unique =
500
+
List.filter (fun m -> m.unique_packages <> []) data.members
501
+
in
418
502
if members_with_unique <> [] then begin
419
503
add "<div class=\"summary\">\n";
420
504
add "<div class=\"summary-title\">Member-Specific Packages</div>\n";
421
505
add "<div class=\"unique-section\">\n";
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;
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;
431
520
add "</div>\n</div>\n"
432
521
end;
433
522
add "</div>\n";
···
436
525
if data.common_repos <> [] then begin
437
526
add "<div class=\"section\">\n<h2>Repository Details</h2>\n";
438
527
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";
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";
445
541
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";
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";
451
547
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;
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;
465
565
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 -> ("", "")
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)
480
574
in
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;
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;
507
621
508
-
add "</div>\n"
509
-
) data.common_repos;
622
+
add "</div>\n")
623
+
data.common_repos;
510
624
511
625
add "</div>\n"
512
626
end;
···
514
628
(* Footer with generation date *)
515
629
let now = Unix.gettimeofday () in
516
630
let tm = Unix.gmtime now in
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));
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));
521
642
522
643
add "</body>\n</html>\n";
523
644
Buffer.contents buf
+14
-11
lib/site.mli
+14
-11
lib/site.mli
···
7
7
8
8
(** {1 Types} *)
9
9
10
-
(** Information about a package in the verse *)
11
10
type pkg_info = {
12
11
name : string;
13
12
synopsis : string option;
···
16
15
owners : string list; (** List of handles that have this package *)
17
16
depends : string list; (** Package dependencies *)
18
17
}
18
+
(** Information about a package in the verse *)
19
19
20
-
(** Information about a repository (group of packages) *)
21
20
type repo_info = {
22
21
ri_name : string;
23
22
ri_dev_repo : string;
24
23
ri_packages : pkg_info list;
25
-
ri_owners : string list; (** All handles that have any package from this repo *)
26
-
ri_fork_status : (string * Forks.relationship) list; (** (handle, relationship) *)
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) *)
27
28
ri_dep_count : int; (** Number of dependencies (for sorting) *)
28
29
}
30
+
(** Information about a repository (group of packages) *)
29
31
30
-
(** Information about a verse member *)
31
32
type member_info = {
32
33
handle : string;
33
34
display_name : string; (** Name to display (from registry or handle) *)
···
36
37
package_count : int;
37
38
unique_packages : string list; (** Packages unique to this member *)
38
39
}
40
+
(** Information about a verse member *)
39
41
40
-
(** Aggregated site data *)
41
42
type site_data = {
42
43
local_handle : string;
43
44
registry_name : string;
···
47
48
unique_repos : repo_info list; (** Repos unique to one member *)
48
49
all_packages : pkg_info list; (** All packages *)
49
50
}
51
+
(** Aggregated site data *)
50
52
51
53
(** {1 Generation} *)
52
54
···
57
59
registry:Verse_registry.t ->
58
60
unit ->
59
61
site_data
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,
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,
62
64
includes fork status information for each repository. *)
63
65
64
66
val generate :
···
68
70
registry:Verse_registry.t ->
69
71
unit ->
70
72
string
71
-
(** [generate ~fs ~config ?forks ~registry ()] generates the HTML content for the site. *)
73
+
(** [generate ~fs ~config ?forks ~registry ()] generates the HTML content for
74
+
the site. *)
72
75
73
76
val write :
74
77
fs:Eio.Fs.dir_ty Eio.Path.t ->
···
78
81
output_path:Fpath.t ->
79
82
unit ->
80
83
(unit, string) result
81
-
(** [write ~fs ~config ?forks ~registry ~output_path ()] generates and writes the site
82
-
to the specified output path. *)
84
+
(** [write ~fs ~config ?forks ~registry ~output_path ()] generates and writes
85
+
the site to the specified output path. *)
+23
-27
lib/sources_registry.ml
+23
-27
lib/sources_registry.ml
···
10
10
origin : origin option;
11
11
}
12
12
13
-
type t = {
14
-
default_url_base : string option;
15
-
entries : (string * entry) list;
16
-
}
13
+
type t = { default_url_base : string option; entries : (string * entry) list }
17
14
18
15
let empty = { default_url_base = None; entries = [] }
19
-
20
16
let default_url_base t = t.default_url_base
21
-
22
-
let with_default_url_base t base =
23
-
{ t with default_url_base = Some base }
24
-
17
+
let with_default_url_base t base = { t with default_url_base = Some base }
25
18
let find t ~subtree = List.assoc_opt subtree t.entries
26
19
27
20
let derive_url t ~subtree =
···
29
22
| Some entry -> Some entry.url
30
23
| None ->
31
24
(* Use default_url_base to construct URL from subtree name *)
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
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
40
34
41
35
let add t ~subtree entry =
42
36
{ t with entries = (subtree, entry) :: List.remove_assoc subtree t.entries }
43
37
44
-
let remove t ~subtree =
45
-
{ t with entries = List.remove_assoc subtree t.entries }
46
-
38
+
let remove t ~subtree = { t with entries = List.remove_assoc subtree t.entries }
47
39
let to_list t = t.entries
48
-
49
40
let of_list entries = { default_url_base = None; entries }
50
41
51
42
(* TOML structure:
···
66
57
~dec:(function
67
58
| "fork" -> Fork
68
59
| "join" -> Join
69
-
| s -> failwith (Printf.sprintf "Invalid origin: %s (expected 'fork' or 'join')" s))
60
+
| s ->
61
+
failwith
62
+
(Printf.sprintf "Invalid origin: %s (expected 'fork' or 'join')" s))
70
63
~enc:(function Fork -> "fork" | Join -> "join")
71
64
Tomlt.string
72
65
73
66
let entry_codec : entry Tomlt.t =
74
67
Tomlt.(
75
68
Table.(
76
-
obj (fun url upstream branch reason origin -> { url; upstream; branch; reason; origin })
69
+
obj (fun url upstream branch reason origin ->
70
+
{ url; upstream; branch; reason; origin })
77
71
|> mem "url" string ~enc:(fun e -> e.url)
78
72
|> opt_mem "upstream" string ~enc:(fun e -> e.upstream)
79
73
|> opt_mem "branch" string ~enc:(fun e -> e.branch)
···
84
78
let codec : t Tomlt.t =
85
79
Tomlt.(
86
80
Table.(
87
-
obj (fun default_url_base entries ->
88
-
{ default_url_base; entries })
81
+
obj (fun default_url_base entries -> { default_url_base; entries })
89
82
|> opt_mem "default_url_base" string ~enc:(fun t -> t.default_url_base)
90
83
|> keep_unknown ~enc:(fun t -> t.entries) (Mems.assoc entry_codec)
91
84
|> finish))
···
98
91
| `Regular_file -> (
99
92
try Ok (Tomlt_eio.decode_path_exn codec ~fs path_str) with
100
93
| Failure msg -> Error (Printf.sprintf "Invalid sources.toml: %s" msg)
101
-
| exn -> Error (Printf.sprintf "Error loading sources.toml: %s" (Printexc.to_string exn)))
102
-
| _ -> Ok empty (* File doesn't exist, return empty registry *)
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 *)
103
99
| exception _ -> Ok empty
104
100
105
101
let save ~fs path t =
+15
-13
lib/sources_registry.mli
+15
-13
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
4
-
the dev-repo URL differs from what's declared in dune-project.
5
-
This is typically used for:
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:
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
11
-
to derive URLs for subtrees without explicit entries:
10
+
The registry also supports a [default_url_base] field that is used to derive
11
+
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 (** Created via [monopam join] - external repo brought into monorepo *)
21
+
| Join
22
+
(** Created via [monopam join] - external repo brought into monorepo *)
22
23
23
-
(** A source entry for a subtree. *)
24
24
type entry = {
25
-
url : string; (** Our dev-repo URL (e.g., "git+https://github.com/avsm/braid") *)
25
+
url : string;
26
+
(** Our dev-repo URL (e.g., "git+https://github.com/avsm/braid") *)
26
27
upstream : string option; (** Original upstream URL if this is a fork *)
27
28
branch : string option; (** Override branch (default: main) *)
28
29
reason : string option; (** Why we have a custom source *)
29
30
origin : origin option; (** How this entry was created *)
30
31
}
32
+
(** A source entry for a subtree. *)
31
33
34
+
type t
32
35
(** The sources registry - maps subtree names to source entries. *)
33
-
type t
34
36
35
37
val empty : t
36
38
(** Empty registry. *)
···
45
47
(** [find t ~subtree] looks up the source entry for a subtree. *)
46
48
47
49
val derive_url : t -> subtree:string -> string option
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. *)
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. *)
50
52
51
53
val add : t -> subtree:string -> entry -> t
52
54
(** [add t ~subtree entry] adds or replaces an entry. *)
···
61
63
(** [of_list entries] creates a registry from an association list. *)
62
64
63
65
val load : fs:_ Eio.Path.t -> Fpath.t -> (t, string) result
64
-
(** [load ~fs path] loads a sources.toml file. Returns empty registry
65
-
if file doesn't exist. *)
66
+
(** [load ~fs path] loads a sources.toml file. Returns empty registry if file
67
+
doesn't exist. *)
66
68
67
69
val save : fs:_ Eio.Path.t -> Fpath.t -> t -> (unit, string) result
68
70
(** [save ~fs path t] writes the registry to a TOML file. *)
+111
-96
lib/status.ml
+111
-96
lib/status.ml
···
1
-
type checkout_status =
2
-
| Missing
3
-
| Not_a_repo
4
-
| Dirty
5
-
| Clean of Git.ahead_behind
6
-
1
+
type ahead_behind = { ahead : int; behind : int }
2
+
type checkout_status = Missing | Not_a_repo | Dirty | Clean of ahead_behind
7
3
type subtree_status = Not_added | Present
8
4
9
5
(** Sync state between monorepo subtree and local checkout *)
···
27
23
let dir, _ = fs in
28
24
(dir, "")
29
25
30
-
let compute ~proc ~fs ~config pkg =
31
-
let checkouts_root = Config.Paths.checkouts config in
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 =
32
62
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
33
-
let monorepo = Config.Paths.monorepo config in
34
63
let prefix = Package.subtree_prefix pkg 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
64
+
let checkout_path = Fpath.to_string checkout_dir in
40
65
let checkout =
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
51
-
in
52
-
let subtree =
53
-
if Git.Subtree.exists ~fs:fs_t ~repo:monorepo ~prefix then Present
54
-
else Not_added
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 }
55
80
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. *)
81
+
let subtree_dir = Fpath.(monorepo / prefix) in
82
+
let subtree = if dir_exists fs subtree_dir then Present else Not_added in
59
83
let subtree_sync =
60
84
match (checkout, subtree) with
61
85
| (Missing | Not_a_repo | Dirty), _ -> Unknown
62
86
| _, Not_added -> Unknown
63
87
| Clean _, Present -> (
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 *)
88
+
let checkout_repo = Git.Repository.open_repo ~fs checkout_path in
89
+
let subtree_tree = Hashtbl.find_opt subtree_hashes prefix in
69
90
let checkout_tree =
70
-
Git.rev_parse ~proc ~fs:fs_t ~rev:"HEAD^{tree}" checkout_dir
91
+
Git.Repository.tree_hash_at_path checkout_repo ~rev:"HEAD" ~path:""
71
92
in
72
93
match (subtree_tree, checkout_tree) with
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 *))
94
+
| Some st, Some ct when Git.Hash.equal st ct -> In_sync
95
+
| Some _, Some _ -> Trees_differ
107
96
| _ -> Unknown)
108
97
in
109
98
{ package = pkg; checkout; subtree; subtree_sync }
110
99
111
-
let compute_all ~proc ~fs ~config packages =
112
-
List.map (compute ~proc ~fs ~config) packages
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
113
116
114
117
let is_checkout_clean t = match t.checkout with Clean _ -> true | _ -> false
115
118
let has_local_changes t = match t.checkout with Dirty -> true | _ -> false
···
160
163
Fmt.pf ppf "@[<h>%-20s checkout: %a subtree: %a@]" (Package.name t.package)
161
164
pp_checkout_status t.checkout pp_subtree_status t.subtree
162
165
163
-
(** Extract handle from a tangled.org URL like "git+https://tangled.org/handle/repo" *)
166
+
(** Extract handle from a tangled.org URL like
167
+
"git+https://tangled.org/handle/repo" *)
164
168
let extract_handle_from_url url =
165
-
let url = if String.starts_with ~prefix:"git+" url then
166
-
String.sub url 4 (String.length url - 4)
167
-
else url in
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
168
174
let uri = Uri.of_string url in
169
175
match Uri.host uri with
170
-
| Some "tangled.org" ->
176
+
| Some "tangled.org" -> (
171
177
let path = Uri.path uri in
172
178
(* Path is like "/handle/repo" - extract first component *)
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)
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)
179
187
| _ -> None
180
188
181
189
(** Format origin indicator from sources registry entry *)
···
184
192
| None -> ()
185
193
| Some Sources_registry.{ origin = Some Sources_registry.Fork; _ } ->
186
194
Fmt.pf ppf " %a" Fmt.(styled `Magenta string) "^"
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:")
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:")
198
213
| Some Sources_registry.{ origin = Some Sources_registry.Join; _ } ->
199
214
Fmt.pf ppf " %a" Fmt.(styled `Cyan string) "v:"
200
215
| Some _ -> ()
···
206
221
let entry = Option.bind sources (fun s -> Sources_registry.find s ~subtree) in
207
222
(* Helper to print remote sync info *)
208
223
let pp_remote ab =
209
-
if ab.Git.ahead > 0 && ab.behind > 0 then
224
+
if ab.ahead > 0 && ab.behind > 0 then
210
225
Fmt.pf ppf " %a"
211
226
Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "remote:+%d/-%d" a b))
212
227
(ab.ahead, ab.behind)
+15
-30
lib/status.mli
+15
-30
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. *)
4
+
locations: git remote, individual checkout, and monorepo subtree. Uses
5
+
native OCaml git library for fast in-process operations. *)
5
6
6
7
(** {1 Types} *)
7
8
9
+
type ahead_behind = { ahead : int; behind : int }
10
+
(** Commits ahead/behind relative to upstream. *)
11
+
8
12
(** Status of an individual checkout relative to its remote. *)
9
13
type checkout_status =
10
14
| Missing (** Checkout directory does not exist *)
11
15
| Not_a_repo (** Directory exists but is not a git repository *)
12
16
| Dirty (** Has uncommitted changes *)
13
-
| Clean of Git.ahead_behind
17
+
| Clean of ahead_behind
14
18
(** Clean with ahead/behind info relative to remote *)
15
19
16
20
(** Status of a subtree in the monorepo. *)
···
40
44
41
45
(** {1 Status Computation} *)
42
46
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 *)
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. *)
55
49
56
50
val compute_all :
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 *)
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. *)
69
53
70
54
(** {1 Predicates} *)
71
55
···
113
97
(** [pp] formats a single package status. *)
114
98
115
99
val pp_compact : ?sources:Sources_registry.t -> t Fmt.t
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). *)
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). *)
118
103
119
104
val pp_summary : ?sources:Sources_registry.t -> t list Fmt.t
120
-
(** [pp_summary ?sources] formats a summary of all package statuses.
121
-
If [sources] is provided, displays origin indicators for each package. *)
105
+
(** [pp_summary ?sources] formats a summary of all package statuses. If
106
+
[sources] is provided, displays origin indicators for each package. *)
+119
-64
lib/verse.ml
+119
-64
lib/verse.ml
···
1
1
type error =
2
2
| Config_error of string
3
-
| Git_error of Git.error
3
+
| Git_error of Git_cli.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 (** List of conflicting package names *)
9
+
| Package_already_exists of string list
10
+
(** List of conflicting package names *)
10
11
| Opam_repo_error of Opam_repo.error
11
12
12
13
let pp_error ppf = function
13
14
| Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
14
-
| Git_error e -> Fmt.pf ppf "Git error: %a" Git.pp_error e
15
+
| Git_error e -> Fmt.pf ppf "Git error: %a" Git_cli.pp_error e
15
16
| Registry_error msg -> Fmt.pf ppf "Registry error: %s" msg
16
17
| Member_not_found h -> Fmt.pf ppf "Member not in registry: %s" h
17
18
| Workspace_exists p -> Fmt.pf ppf "Workspace already exists: %a" Fpath.pp p
···
20
21
Fmt.pf ppf "Package %s not found in %s's opam repo" pkg handle
21
22
| Package_already_exists pkgs ->
22
23
Fmt.pf ppf "Packages already exist in your opam repo: %a"
23
-
Fmt.(list ~sep:comma string) pkgs
24
+
Fmt.(list ~sep:comma string)
25
+
pkgs
24
26
| Opam_repo_error e -> Fmt.pf ppf "Opam repo error: %a" Opam_repo.pp_error e
25
27
26
28
let error_hint = function
27
29
| Config_error _ ->
28
-
Some
29
-
"Run 'monopam init --handle <your-handle>' to create a workspace."
30
-
| Git_error (Git.Dirty_worktree _) ->
30
+
Some "Run 'monopam init --handle <your-handle>' to create a workspace."
31
+
| Git_error (Git_cli.Dirty_worktree _) ->
31
32
Some "Commit or stash your changes first: git status"
32
-
| Git_error (Git.Command_failed (cmd, _))
33
+
| Git_error (Git_cli.Command_failed (cmd, _))
33
34
when String.starts_with ~prefix:"git clone" cmd ->
34
35
Some "Check the URL is correct and you have network access."
35
-
| Git_error (Git.Command_failed (cmd, _))
36
+
| Git_error (Git_cli.Command_failed (cmd, _))
36
37
when String.starts_with ~prefix:"git pull" cmd ->
37
38
Some "Check your network connection. Try: git fetch origin"
38
39
| Git_error _ -> None
···
45
46
| Workspace_exists _ ->
46
47
Some "Use a different directory, or remove the existing workspace."
47
48
| Not_a_workspace _ ->
48
-
Some "Run 'monopam init --handle <your-handle>' to create a workspace here."
49
+
Some
50
+
"Run 'monopam init --handle <your-handle>' to create a workspace here."
49
51
| Package_not_found (pkg, handle) ->
50
-
Some (Fmt.str "Run 'monopam verse pull %s' to sync their opam repo, then check package name: %s" handle pkg)
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)
51
57
| Package_already_exists 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)))
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)))
54
62
| Opam_repo_error _ -> None
55
63
56
64
let pp_error_with_hint ppf e =
···
65
73
local_path : Fpath.t;
66
74
cloned : bool;
67
75
clean : bool option;
68
-
ahead_behind : Git.ahead_behind option;
76
+
ahead_behind : Git_cli.ahead_behind option;
69
77
}
70
78
71
79
type status = {
···
180
188
Logs.info (fun m -> m "Cloning monorepo to %a" Fpath.pp mono_path);
181
189
let mono_url = Uri.of_string member.monorepo in
182
190
match
183
-
Git.clone ~proc ~fs ~url:mono_url
191
+
Git_cli.clone ~proc ~fs ~url:mono_url
184
192
~branch:Verse_config.default_branch mono_path
185
193
with
186
194
| Error e ->
187
-
Logs.err (fun m -> m "Monorepo clone failed: %a" Git.pp_error e);
195
+
Logs.err (fun m ->
196
+
m "Monorepo clone failed: %a" Git_cli.pp_error e);
188
197
Error (Git_error e)
189
198
| Ok () -> (
190
199
Logs.info (fun m -> m "Monorepo cloned");
···
194
203
m "Cloning opam repo to %a" Fpath.pp opam_path);
195
204
let opam_url = Uri.of_string member.opamrepo in
196
205
match
197
-
Git.clone ~proc ~fs ~url:opam_url
206
+
Git_cli.clone ~proc ~fs ~url:opam_url
198
207
~branch:Verse_config.default_branch opam_path
199
208
with
200
209
| Error e ->
201
210
Logs.err (fun m ->
202
-
m "Opam repo clone failed: %a" Git.pp_error e);
211
+
m "Opam repo clone failed: %a" Git_cli.pp_error e);
203
212
Error (Git_error e)
204
213
| Ok () -> (
205
214
Logs.info (fun m -> m "Opam repo cloned");
···
247
256
let local_path =
248
257
Fpath.(Verse_config.verse_path config / handle)
249
258
in
250
-
let cloned = Git.is_repo ~proc ~fs local_path in
259
+
let cloned = Git_cli.is_repo ~proc ~fs local_path in
251
260
let clean =
252
-
if cloned then Some (not (Git.is_dirty ~proc ~fs local_path))
261
+
if cloned then
262
+
Some (not (Git_cli.is_dirty ~proc ~fs local_path))
253
263
else None
254
264
in
255
265
let ahead_behind =
256
266
if cloned then
257
-
match Git.ahead_behind ~proc ~fs local_path with
267
+
match Git_cli.ahead_behind ~proc ~fs local_path with
258
268
| Ok ab -> Some ab
259
269
| Error _ -> None
260
270
else None
···
277
287
| Error msg -> Error (Registry_error msg)
278
288
| Ok registry -> Ok registry.members
279
289
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. *)
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. *)
282
293
let clone_or_reset_repo ~proc ~fs ~url ~branch path =
283
-
if Git.is_repo ~proc ~fs path then begin
284
-
match Git.fetch_and_reset ~proc ~fs ~branch path with
294
+
if Git_cli.is_repo ~proc ~fs path then begin
295
+
match Git_cli.fetch_and_reset ~proc ~fs ~branch path with
285
296
| Error e -> Error e
286
297
| Ok () -> Ok false
287
298
end
288
299
else begin
289
300
let url = Uri.of_string url in
290
-
match Git.clone ~proc ~fs ~url ~branch path with
301
+
match Git_cli.clone ~proc ~fs ~url ~branch path with
291
302
| Error e -> Error e
292
303
| Ok () -> Ok true
293
304
end
···
311
322
let verse_dir = Verse_config.verse_path config in
312
323
ensure_dir ~fs verse_dir;
313
324
Logs.info (fun m -> m "Syncing %d members" (List.length members));
325
+
(* Sync all members in parallel *)
314
326
let errors =
315
-
List.filter_map
327
+
Eio.Fiber.List.filter_map ~max_fibers:4
316
328
(fun (member : Verse_registry.member) ->
317
329
let h = member.handle in
318
330
let mono_path = Fpath.(verse_dir / h) in
···
320
332
(* Clone or fetch+reset monorepo *)
321
333
Logs.info (fun m -> m "Syncing %s monorepo" h);
322
334
let mono_branch =
323
-
Option.value ~default:Verse_config.default_branch member.monorepo_branch
335
+
Option.value ~default:Verse_config.default_branch
336
+
member.monorepo_branch
324
337
in
325
338
let mono_result =
326
339
clone_or_reset_repo ~proc ~fs ~url:member.monorepo
···
336
349
None
337
350
| Error e ->
338
351
Logs.warn (fun m ->
339
-
m " Failed %s monorepo: %a" h Git.pp_error e);
340
-
Some (Fmt.str "%s monorepo: %a" h Git.pp_error e)
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)
341
354
in
342
355
(* Clone or fetch+reset opam repo *)
343
356
Logs.info (fun m -> m "Syncing %s opam repo" h);
344
357
let opam_branch =
345
-
Option.value ~default:Verse_config.default_branch member.opamrepo_branch
358
+
Option.value ~default:Verse_config.default_branch
359
+
member.opamrepo_branch
346
360
in
347
361
let opam_result =
348
362
clone_or_reset_repo ~proc ~fs ~url:member.opamrepo
···
358
372
None
359
373
| Error e ->
360
374
Logs.warn (fun m ->
361
-
m " Failed %s opam repo: %a" h Git.pp_error e);
362
-
Some (Fmt.str "%s opam: %a" h Git.pp_error e)
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)
363
377
in
364
378
match (mono_err, opam_err) with
365
379
| None, None -> None
···
368
382
members
369
383
in
370
384
if errors = [] then Ok ()
371
-
else Error (Git_error (Git.Io_error (String.concat "; " errors)))
385
+
else Error (Git_error (Git_cli.Io_error (String.concat "; " errors)))
372
386
end
373
387
374
388
let sync ~proc ~fs ~config () =
···
378
392
(** Scan a monorepo for subtree directories. Returns a list of directory names
379
393
that look like subtrees (have commits). *)
380
394
let scan_subtrees ~proc ~fs monorepo_path =
381
-
if not (Git.is_repo ~proc ~fs monorepo_path) then []
395
+
if not (Git_cli.is_repo ~proc ~fs monorepo_path) then []
382
396
else
383
397
let eio_path = Eio.Path.(fs / Fpath.to_string monorepo_path) in
384
398
try
···
400
414
List.iter
401
415
(fun handle ->
402
416
let member_mono = Fpath.(verse_path / handle) in
403
-
if Git.is_repo ~proc ~fs member_mono then begin
417
+
if Git_cli.is_repo ~proc ~fs member_mono then begin
404
418
let subtrees = scan_subtrees ~proc ~fs member_mono in
405
419
List.iter
406
420
(fun subtree ->
···
414
428
tracked_handles;
415
429
subtree_map
416
430
417
-
(** Result of a fork operation. *)
418
431
type fork_result = {
419
432
packages_forked : string list; (** Package names that were forked *)
420
433
source_handle : string; (** Handle of the verse member we forked from *)
421
434
fork_url : string; (** URL of the fork *)
422
435
upstream_url : string; (** Original dev-repo URL (upstream) *)
423
-
subtree_name : string; (** Name for the subtree directory (derived from fork URL) *)
436
+
subtree_name : string;
437
+
(** Name for the subtree directory (derived from fork URL) *)
424
438
}
439
+
(** Result of a fork operation. *)
425
440
426
441
(** Extract subtree name from a URL (last path component without .git suffix) *)
427
442
let subtree_name_from_url url =
428
443
let uri = Uri.of_string url in
429
444
let path = Uri.path uri in
430
445
(* Remove leading slash and .git suffix *)
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
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
437
456
(* Get last component *)
438
457
match String.rindex_opt path '/' with
439
458
| Some i -> String.sub path (i + 1) (String.length path - i - 1)
440
459
| None -> path
441
460
442
461
let pp_fork_result ppf r =
443
-
Fmt.pf ppf "@[<v>Forked %d package(s) from %s:@, @[<v>%a@]@,Fork URL: %s@,Upstream: %s@,Subtree: %s@]"
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@]"
444
468
(List.length r.packages_forked)
445
469
r.source_handle
446
-
Fmt.(list ~sep:cut string) r.packages_forked
447
-
r.fork_url
448
-
r.upstream_url
449
-
r.subtree_name
470
+
Fmt.(list ~sep:cut string)
471
+
r.packages_forked r.fork_url r.upstream_url r.subtree_name
450
472
451
473
(** Fork a package from a verse member's opam repo into your workspace.
452
474
···
465
487
(* Ensure the member exists and their opam-repo is synced *)
466
488
match Verse_registry.clone_or_pull ~proc ~fs ~config () with
467
489
| Error msg -> Error (Registry_error msg)
468
-
| Ok registry ->
490
+
| Ok registry -> (
469
491
match Verse_registry.find_member registry ~handle with
470
492
| None -> Error (Member_not_found handle)
471
-
| Some _member ->
493
+
| Some _member -> (
472
494
let verse_path = Verse_config.verse_path config in
473
495
let member_opam_repo = Fpath.(verse_path / (handle ^ "-opam")) in
474
496
(* Check if their opam repo exists locally *)
475
497
if not (is_directory ~fs member_opam_repo) then
476
-
Error (Config_error (Fmt.str "Member's opam repo not synced. Run: monopam verse pull %s" handle))
498
+
Error
499
+
(Config_error
500
+
(Fmt.str
501
+
"Member's opam repo not synced. Run: monopam verse pull %s"
502
+
handle))
477
503
else
478
504
(* Scan their opam repo to find the package *)
479
505
let pkgs, _errors = Opam_repo.scan_all ~fs member_opam_repo in
···
493
519
let user_opam_repo = Verse_config.opam_repo_path config in
494
520
let conflicts =
495
521
List.filter
496
-
(fun name -> Opam_repo.package_exists ~fs ~repo_path:user_opam_repo ~name)
522
+
(fun name ->
523
+
Opam_repo.package_exists ~fs ~repo_path:user_opam_repo
524
+
~name)
497
525
pkg_names
498
526
in
499
-
if conflicts <> [] then
500
-
Error (Package_already_exists conflicts)
527
+
if conflicts <> [] then Error (Package_already_exists conflicts)
501
528
else if dry_run then
502
529
(* Dry run - just report what would be done *)
503
-
Ok { packages_forked = pkg_names; source_handle = handle; fork_url; upstream_url; subtree_name }
530
+
Ok
531
+
{
532
+
packages_forked = pkg_names;
533
+
source_handle = handle;
534
+
fork_url;
535
+
upstream_url;
536
+
subtree_name;
537
+
}
504
538
else begin
505
539
(* Fork each package *)
506
540
let results =
···
509
543
let name = Package.name p in
510
544
let version = Package.version p in
511
545
let opam_path =
512
-
Fpath.(member_opam_repo / "packages" / name / (name ^ "." ^ version) / "opam")
546
+
Fpath.(
547
+
member_opam_repo / "packages" / name
548
+
/ (name ^ "." ^ version)
549
+
/ "opam")
513
550
in
514
551
match Opam_repo.read_opam_file ~fs opam_path with
515
552
| Error e -> Error (Opam_repo_error e)
516
-
| Ok content ->
553
+
| Ok content -> (
517
554
(* Replace dev-repo and url with fork URL *)
518
-
let new_content = Opam_repo.replace_dev_repo_url content ~new_url:fork_url in
555
+
let new_content =
556
+
Opam_repo.replace_dev_repo_url content
557
+
~new_url:fork_url
558
+
in
519
559
(* Write to user's opam-repo *)
520
-
match Opam_repo.write_package ~fs ~repo_path:user_opam_repo ~name ~version ~content:new_content with
560
+
match
561
+
Opam_repo.write_package ~fs
562
+
~repo_path:user_opam_repo ~name ~version
563
+
~content:new_content
564
+
with
521
565
| Error e -> Error (Opam_repo_error e)
522
-
| Ok () -> Ok name)
566
+
| Ok () -> Ok name))
523
567
related_pkgs
524
568
in
525
569
(* Check for errors *)
526
570
match List.find_opt Result.is_error results with
527
571
| Some (Error e) -> Error e
528
572
| _ ->
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
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))
+9
-6
lib/verse.mli
+9
-6
lib/verse.mli
···
7
7
8
8
type error =
9
9
| Config_error of string (** Configuration loading/saving error *)
10
-
| Git_error of Git.error (** Git operation failed *)
10
+
| Git_error of Git_cli.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 (** Package not found in member's repo: (package, handle) *)
16
-
| Package_already_exists of string list (** Packages already exist in user's opam repo *)
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 *)
17
19
| Opam_repo_error of Opam_repo.error (** Error reading/writing opam files *)
18
20
19
21
val pp_error : error Fmt.t
···
34
36
local_path : Fpath.t; (** Local path under verse/ *)
35
37
cloned : bool; (** Whether the monorepo is cloned locally *)
36
38
clean : bool option; (** Whether the clone is clean (None if not cloned) *)
37
-
ahead_behind : Git.ahead_behind option;
39
+
ahead_behind : Git_cli.ahead_behind option;
38
40
(** Ahead/behind status (None if not cloned) *)
39
41
}
40
42
(** Status of a member's monorepo in the workspace. *)
···
149
151
150
152
(** {1 Forking} *)
151
153
152
-
(** Result of a fork operation. *)
153
154
type fork_result = {
154
155
packages_forked : string list; (** Package names that were forked *)
155
156
source_handle : string; (** Handle of the verse member we forked from *)
156
157
fork_url : string; (** URL of the fork *)
157
158
upstream_url : string; (** Original dev-repo URL (upstream) *)
158
-
subtree_name : string; (** Name for the subtree directory (derived from fork URL) *)
159
+
subtree_name : string;
160
+
(** Name for the subtree directory (derived from fork URL) *)
159
161
}
162
+
(** Result of a fork operation. *)
160
163
161
164
val pp_fork_result : fork_result Fmt.t
162
165
(** [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.
4
-
All functionality has been unified into Config. *)
3
+
This module is kept for backwards compatibility. All functionality has been
4
+
unified into Config. *)
5
5
6
6
include Config
7
7
8
-
(** Legacy type alias for package overrides *)
9
8
type package_override = Config.Package_config.t
9
+
(** Legacy type alias for package overrides *)
+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.
4
-
All functionality has been unified into Config.
3
+
This module is kept for backwards compatibility. All functionality has been
4
+
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
10
11
(** Legacy type alias for package overrides.
11
12
@deprecated Use {!Config.Package_config.t} instead. *)
12
-
type package_override = Config.Package_config.t
+23
-15
lib/verse_registry.ml
+23
-15
lib/verse_registry.ml
···
6
6
opamrepo : string;
7
7
opamrepo_branch : string option;
8
8
}
9
+
9
10
type t = { name : string; description : string option; members : member list }
10
11
11
12
let default_url = "https://tangled.org/eeg.cl.cam.ac.uk/opamverse"
···
21
22
22
23
(** Encode a URL with optional branch suffix. *)
23
24
let encode_url_with_branch url branch =
24
-
match branch with
25
-
| None -> url
26
-
| Some b -> url ^ "#" ^ b
25
+
match branch with None -> url | Some b -> url ^ "#" ^ b
27
26
28
27
let pp_member ppf m =
29
28
let mono_str = encode_url_with_branch m.monorepo m.monorepo_branch in
30
29
let opam_str = encode_url_with_branch m.opamrepo m.opamrepo_branch in
31
30
let name_str = match m.name with Some n -> n | None -> m.handle in
32
-
Fmt.pf ppf "@[<hov 2>%s (%s) ->@ mono:%s@ opam:%s@]" name_str m.handle mono_str opam_str
31
+
Fmt.pf ppf "@[<hov 2>%s (%s) ->@ mono:%s@ opam:%s@]" name_str m.handle
32
+
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)) t.description
36
+
Fmt.(option (fun ppf s -> pf ppf "@,description: %s" s))
37
+
t.description
37
38
Fmt.(list ~sep:cut pp_member)
38
39
t.members
39
40
···
56
57
{ handle; name; monorepo; monorepo_branch; opamrepo; opamrepo_branch })
57
58
|> mem "handle" string ~enc:(fun (m : member) -> m.handle)
58
59
|> opt_mem "name" string ~enc:(fun (m : member) -> m.name)
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)
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)
61
64
|> finish))
62
65
63
66
type registry_info = { r_name : string; r_description : string option }
···
74
77
Tomlt.(
75
78
Table.(
76
79
obj (fun registry members ->
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 })
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 })
79
87
|> opt_mem "members" (list member_codec) ~enc:(fun t ->
80
88
match t.members with [] -> None | ms -> Some ms)
81
89
|> finish))
···
117
125
let exists =
118
126
let path = Eio.Path.(fs / Fpath.to_string registry_path) in
119
127
match Eio.Path.kind ~follow:true path with
120
-
| `Directory -> Git.is_repo ~proc ~fs registry_path
128
+
| `Directory -> Git_cli.is_repo ~proc ~fs registry_path
121
129
| _ -> false
122
130
| exception _ -> false
123
131
in
124
132
if exists then begin
125
133
Logs.info (fun m -> m "Registry exists, pulling updates...");
126
134
(* Pull updates, but don't fail if pull fails *)
127
-
(match Git.pull ~proc ~fs registry_path with
135
+
(match Git_cli.pull ~proc ~fs registry_path with
128
136
| Ok () -> Logs.info (fun m -> m "Registry pull succeeded")
129
137
| Error e ->
130
138
Logs.warn (fun m ->
131
-
m "Registry pull failed: %a (using cached)" Git.pp_error e));
139
+
m "Registry pull failed: %a (using cached)" Git_cli.pp_error e));
132
140
Logs.info (fun m -> m "Loading registry from %a" Fpath.pp registry_toml);
133
141
load ~fs registry_toml
134
142
end
···
141
149
(* Try to clone the registry *)
142
150
let url = Uri.of_string default_url in
143
151
let branch = "main" in
144
-
match Git.clone ~proc ~fs ~url ~branch registry_path with
152
+
match Git_cli.clone ~proc ~fs ~url ~branch registry_path with
145
153
| Ok () ->
146
154
Logs.info (fun m -> m "Registry cloned successfully");
147
155
load ~fs registry_toml
148
156
| Error e ->
149
-
Logs.warn (fun m -> m "Registry clone failed: %a" Git.pp_error e);
157
+
Logs.warn (fun m -> m "Registry clone failed: %a" Git_cli.pp_error e);
150
158
Logs.info (fun m -> m "Creating empty local registry...");
151
159
(* Clone failed - create local registry directory with empty registry *)
152
160
let registry_eio = Eio.Path.(fs / Fpath.to_string registry_path) in
153
161
(try Eio.Path.mkdirs ~perm:0o755 registry_eio with Eio.Io _ -> ());
154
162
(* Initialize as git repo *)
155
-
(match Git.init ~proc ~fs registry_path with
163
+
(match Git_cli.init ~proc ~fs registry_path with
156
164
| Ok () -> ()
157
165
| Error _ -> ());
158
166
(* Create empty registry file *)
+6
-4
lib/verse_registry.mli
+6
-4
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; (** Optional branch for monorepo (from URL#branch) *)
12
+
monorepo_branch : string option;
13
+
(** Optional branch for monorepo (from URL#branch) *)
13
14
opamrepo : string; (** Git URL of the member's opam overlay repository *)
14
-
opamrepo_branch : string option; (** Optional branch for opam repo (from URL#branch) *)
15
+
opamrepo_branch : string option;
16
+
(** Optional branch for opam repo (from URL#branch) *)
15
17
}
16
18
(** A registry member entry.
17
19
18
-
URLs may include a [#branch] suffix to specify a non-default branch.
19
-
For example, ["https://github.com/user/repo#develop"]. *)
20
+
URLs may include a [#branch] suffix to specify a non-default branch. For
21
+
example, ["https://github.com/user/repo#develop"]. *)
20
22
21
23
type t = {
22
24
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
+
]