forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
ocaml-git: native Git.Fetch.fetch_local for file:// URLs
Pure-OCaml object-graph walk + copy between two on-disk repos. No git
subprocess, no zlib re-compression — file:// fetches in monopam tests
and the local-checkout daily flow now go through ocaml-git directly.
Architecture: pure core / Eio shell. Git.Fetch.reachable_from is a pure
DFS over the (commit, tree, blob, tag) reachability graph parameterised
on read/exists callbacks; Git.Fetch.fetch_local is the I/O wrapper that
opens repos, walks, copies, and writes FETCH_HEAD + refs/remotes/origin.
Wired into monopam/lib/git_cli.ml: fetch_url now switches on parse_url
and routes file:// (and bare local paths) through fetch_local. HTTP/SSH
URLs still shell out to git fetch. The added ~sw parameter threads the
Eio switch to keep Repository handles bounded.
Drive-by fixes uncovered by the new path:
- Repository.write_ref: use Eio.Path.mkdirs so refs/remotes/origin/<b>
works (mkdir only creates one level and crashed on the nested path)
- git_cli.open_local: detect bare vs non-bare repos by probing .git/
Tests: 11 new cases in ocaml-git/test/test_fetch.ml covering parse_url,
reachable_from order/incremental skip, and fetch_local basic/incremental
/unknown-ref. All ocaml-git + monopam suites pass.
+63
-19
+2
-2
lib/fork_join.ml
+2
-2
lib/fork_join.ml
···
776
776
777
777
(** Execute subtree add action. *)
778
778
let exec_subtree_add ~sw ~proc ~fs ~repo ~prefix ~url ~branch =
779
-
match Git_cli.fetch_url ~proc ~fs ~repo ~url ~branch () with
779
+
match Git_cli.fetch_url ~sw ~proc ~fs ~repo ~url ~branch () with
780
780
| Error e -> Error (Git_error e)
781
781
| Ok hash_hex -> (
782
782
let git_repo = Git.Repository.open_repo ~sw ~fs repo in
···
1058
1058
| None -> ()
1059
1059
1060
1060
let join_add_subtree ~sw ~proc ~fs ~monorepo ~prefix ~url ~branch =
1061
-
match Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url ~branch () with
1061
+
match Git_cli.fetch_url ~sw ~proc ~fs ~repo:monorepo ~url ~branch () with
1062
1062
| Error e -> Error (Git_error e)
1063
1063
| Ok hash_hex ->
1064
1064
let git_repo = Git.Repository.open_repo ~sw ~fs monorepo in
+43
-11
lib/git_cli.ml
+43
-11
lib/git_cli.ml
···
200
200
let upstream = remote ^ "/" ^ branch in
201
201
run_git_ok ~proc ~cwd [ "reset"; "--hard"; upstream ] |> Result.map ignore
202
202
203
-
(* Fetch from URL and return the commit hash for the branch *)
204
-
let fetch_url ~proc ~fs ~repo ~url ~branch () =
205
-
let cwd = path_to_eio ~fs repo in
206
-
let url_str = url in
207
-
(* Fetch into FETCH_HEAD *)
208
-
match run_git_ok_with_retry ~proc ~cwd [ "fetch"; url_str; branch ] with
209
-
| Error e -> Error e
210
-
| Ok _ -> (
211
-
(* Get the fetched commit hash *)
212
-
match run_git_ok ~proc ~cwd [ "rev-parse"; "FETCH_HEAD" ] with
203
+
(** Open a local git repository, detecting whether it's bare or not. A bare repo
204
+
has [HEAD] / [refs/] / [objects/] directly under [path]; a regular one has
205
+
them under [path/.git/]. *)
206
+
let open_local ~sw ~fs path =
207
+
let dotgit = Eio.Path.(fs / Fpath.to_string path / ".git") in
208
+
match Eio.Path.kind ~follow:true dotgit with
209
+
| `Directory -> Git.Repository.open_repo ~sw ~fs path
210
+
| _ | (exception _) -> Git.Repository.open_bare ~sw ~fs path
211
+
212
+
(* Fetch from URL and return the commit hash for the branch.
213
+
214
+
For file:// URLs (and bare local paths) this uses the native
215
+
[Git.Fetch.fetch_local] which copies objects directly between the two
216
+
on-disk repos — no [git] subprocess, no zlib re-compression of pack
217
+
contents, fully cancellable via the Eio switch. The native path covers
218
+
the entire monopam test suite and the daily-driver local-checkout flow
219
+
(under [src/]). HTTP/SSH URLs still go through [git fetch]. *)
220
+
let fetch_url ~sw ~proc ~fs ~repo ~url ~branch () =
221
+
match Git.Fetch.parse_url url with
222
+
| `File src_path -> (
223
+
let src_fpath =
224
+
match Fpath.of_string src_path with
225
+
| Ok p -> p
226
+
| Error (`Msg m) ->
227
+
failwith ("fetch_url: bad path " ^ src_path ^ ": " ^ m)
228
+
in
229
+
try
230
+
let src_repo = open_local ~sw ~fs src_fpath in
231
+
let dst_repo = open_local ~sw ~fs repo in
232
+
match
233
+
Git.Fetch.fetch_local ~src:src_repo ~dst:dst_repo ~ref_name:branch
234
+
with
235
+
| Ok hash -> Ok (Git.Hash.to_hex hash)
236
+
| Error (`Msg msg) -> Error (Io_error msg)
237
+
with e -> Error (Io_error (Printexc.to_string e)))
238
+
| `Other _ -> (
239
+
let cwd = path_to_eio ~fs repo in
240
+
let url_str = url in
241
+
match run_git_ok_with_retry ~proc ~cwd [ "fetch"; url_str; branch ] with
213
242
| Error e -> Error e
214
-
| Ok hash -> Ok (String.trim hash))
243
+
| Ok _ -> (
244
+
match run_git_ok ~proc ~cwd [ "rev-parse"; "FETCH_HEAD" ] with
245
+
| Error e -> Error e
246
+
| Ok hash -> Ok (String.trim hash)))
215
247
216
248
let push_refspec ~proc ~fs ~repo ~url ~refspec ?(force = false) () =
217
249
let cwd = path_to_eio ~fs repo in
+10
-2
lib/git_cli.mli
+10
-2
lib/git_cli.mli
···
129
129
(** {1 Subtree Helper Operations} *)
130
130
131
131
val fetch_url :
132
+
sw:Eio.Switch.t ->
132
133
proc:_ Eio.Process.mgr ->
133
134
fs:Eio.Fs.dir_ty Eio.Path.t ->
134
135
repo:Fpath.t ->
···
136
137
branch:string ->
137
138
unit ->
138
139
(string, error) result
139
-
(** [fetch_url ~proc ~fs ~repo ~url ~branch ()] fetches a branch from a URL and
140
-
returns the commit hash of [FETCH_HEAD].
140
+
(** [fetch_url ~sw ~proc ~fs ~repo ~url ~branch ()] fetches a branch from a URL
141
+
and returns the commit hash of [FETCH_HEAD].
141
142
143
+
For [file://] URLs and bare local paths the fetch goes through
144
+
{!Git.Fetch.fetch_local} — pure OCaml, no [git] subprocess. HTTP/SSH URLs
145
+
still shell out to [git fetch].
146
+
147
+
@param sw
148
+
Eio switch holding any Repository handles opened by the native local fetch
149
+
path.
142
150
@param repo Path to the local repository.
143
151
@param url Git remote URL to fetch from.
144
152
@param branch Branch to fetch. *)
+1
-1
lib/import.ml
+1
-1
lib/import.ml
+7
-3
lib/pull.ml
+7
-3
lib/pull.ml
···
109
109
Error
110
110
(Ctx.Git_error (Git_cli.Io_error "checkout has no HEAD, cannot pull"))
111
111
| Some head -> (
112
-
match Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url ~branch () with
112
+
match Git_cli.fetch_url ~sw ~proc ~fs ~repo:monorepo ~url ~branch () with
113
113
| Error e -> Error (Ctx.Git_error e)
114
114
| Ok _ -> (
115
115
let git_repo = Git.Repository.open_repo ~sw ~fs monorepo in
···
154
154
checkout_dir path);
155
155
merge_subtree ~git_repo ~prefix ~commit:split_hash ~user ~url)
156
156
| None -> (
157
-
match Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url ~branch () with
157
+
match
158
+
Git_cli.fetch_url ~sw ~proc ~fs ~repo:monorepo ~url ~branch ()
159
+
with
158
160
| Error e -> Error (Ctx.Git_error e)
159
161
| Ok hash_hex ->
160
162
let git_repo = Git.Repository.open_repo ~sw ~fs monorepo in
···
385
387
[]
386
388
end
387
389
else
388
-
match Git_cli.fetch_url ~proc ~fs:fs_t ~repo:monorepo ~url ~branch () with
390
+
match
391
+
Git_cli.fetch_url ~sw ~proc ~fs:fs_t ~repo:monorepo ~url ~branch ()
392
+
with
389
393
| Error e ->
390
394
Log.warn (fun m ->
391
395
m "Failed to fetch %s into monorepo: %a" prefix Git_cli.pp_error e);