forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
refactor: rename d3t to wire across codebase
Rename the d3t library to wire for clarity. Update all references
in bench, test, and library code across affected packages.
+137
-135
+82
-50
bin/cmd_test.ml
+82
-50
bin/cmd_test.ml
···
4
4
5
5
module Log = (val Logs.src_log src)
6
6
7
-
type result = {
8
-
name : string;
9
-
duration : float;
10
-
status : [ `Ok | `Slow | `Fail | `Timeout ];
11
-
}
7
+
type status = [ `Ok | `Slow | `Fail | `Timeout | `Build_fail ]
8
+
type result = { name : string; duration : float; status : status }
12
9
13
10
let status_to_string = function
14
11
| `Ok -> "OK"
15
12
| `Slow -> "SLOW"
16
13
| `Fail -> "FAIL"
17
14
| `Timeout -> "TIMEOUT"
15
+
| `Build_fail -> "FAIL (build)"
16
+
17
+
let run_cmd ~process_mgr cmd =
18
+
let args = [ "sh"; "-c"; cmd ] in
19
+
Eio.Switch.run @@ fun sw ->
20
+
let proc = Eio.Process.spawn ~sw process_mgr args in
21
+
Eio.Process.await proc
18
22
19
23
let run_test_eio ~process_mgr ~timeout dir =
20
24
let cmd = Printf.sprintf "timeout %ds dune test %s 2>&1" timeout dir in
21
-
Log.info (fun m -> m "Running: %s" cmd);
25
+
Log.debug (fun m -> m "Running: %s" cmd);
22
26
let start = Unix.gettimeofday () in
23
-
let args = [ "sh"; "-c"; cmd ] in
24
-
Eio.Switch.run @@ fun sw ->
25
-
let proc = Eio.Process.spawn ~sw process_mgr args in
26
-
let status = Eio.Process.await proc in
27
+
let status = run_cmd ~process_mgr cmd in
27
28
let duration = Unix.gettimeofday () -. start in
28
29
let status =
29
30
match status with
···
31
32
| `Exited 124 -> `Timeout
32
33
| _ -> `Fail
33
34
in
34
-
Log.info (fun m ->
35
+
Log.debug (fun m ->
35
36
m " %s: %s (%.2fs)" dir (status_to_string status) duration);
36
37
{ name = dir; duration; status }
37
38
38
-
let find_test_dirs () =
39
-
let cmd =
40
-
"find . -name 'test' -type d -path '*/test' | grep -v _build | grep -v \
41
-
_opam | sort"
42
-
in
43
-
let ic = Unix.open_process_in cmd in
44
-
let lines = In_channel.input_all ic |> String.split_on_char '\n' in
45
-
let _ = Unix.close_process_in ic in
46
-
lines
47
-
|> List.filter (fun s -> s <> "")
48
-
|> List.filter_map (fun path ->
49
-
match String.split_on_char '/' path with
50
-
| [ "."; dir; "test" ] -> Some dir
51
-
| _ -> None)
52
-
|> List.sort_uniq String.compare
39
+
let find_test_dirs ~fs =
40
+
let cwd = Eio.Path.(fs / ".") in
41
+
Eio.Path.read_dir cwd
42
+
|> List.filter (fun d ->
43
+
d.[0] <> '_'
44
+
&& d.[0] <> '.'
45
+
&& Eio.Path.kind ~follow:true Eio.Path.(cwd / d) = `Directory
46
+
&& Eio.Path.kind ~follow:true Eio.Path.(cwd / d / "test") = `Directory)
47
+
|> List.sort String.compare
53
48
54
49
let status_style = function
55
50
| `Ok -> Tty.Style.(fg (Tty.Color.ansi `Green))
56
51
| `Slow -> Tty.Style.(fg (Tty.Color.ansi `Yellow))
57
-
| `Fail -> Tty.Style.(fg (Tty.Color.ansi `Red))
58
-
| `Timeout -> Tty.Style.(fg (Tty.Color.ansi `Red))
52
+
| `Fail | `Timeout | `Build_fail -> Tty.Style.(fg (Tty.Color.ansi `Red))
59
53
60
54
let styled style s = Fmt.str "%a" (Tty.Style.styled style Fmt.string) s
61
55
62
-
let prebuild ~process_mgr dirs =
63
-
(* Pre-build all test directories to warm up dune cache *)
64
-
let targets = String.concat " " dirs in
65
-
let cmd = Printf.sprintf "dune build %s 2>/dev/null" targets in
66
-
Log.info (fun m -> m "Running: %s" cmd);
67
-
let args = [ "sh"; "-c"; cmd ] in
68
-
Eio.Switch.run @@ fun sw ->
69
-
let proc = Eio.Process.spawn ~sw process_mgr args in
70
-
let _ = Eio.Process.await proc in
71
-
()
56
+
let prebuild ~process_mgr ~timeout dirs =
57
+
let total = List.length dirs in
58
+
let bar = Tty.Progress.create ~total "Building" in
59
+
let build_failures =
60
+
List.filter_map
61
+
(fun dir ->
62
+
Tty.Progress.update bar ~phase:"build" ~msg:dir;
63
+
let cmd = Printf.sprintf "timeout %ds dune build %s 2>&1" timeout dir in
64
+
Log.debug (fun m -> m "Running: %s" cmd);
65
+
let start = Unix.gettimeofday () in
66
+
let status = run_cmd ~process_mgr cmd in
67
+
let duration = Unix.gettimeofday () -. start in
68
+
match status with
69
+
| `Exited 0 ->
70
+
Log.debug (fun m -> m " %s: built (%.2fs)" dir duration);
71
+
None
72
+
| `Exited 124 ->
73
+
Log.info (fun m -> m " %s: build timed out after %ds" dir timeout);
74
+
Some { name = dir; duration; status = `Build_fail }
75
+
| _ ->
76
+
Log.info (fun m -> m " %s: build failed (%.2fs)" dir duration);
77
+
Some { name = dir; duration; status = `Build_fail })
78
+
dirs
79
+
in
80
+
Tty.Progress.finish bar;
81
+
build_failures
72
82
73
83
let run_tests_sequential ~process_mgr ~timeout dirs =
74
-
(* Run tests sequentially - they share the dune build lock *)
75
-
List.map (run_test_eio ~process_mgr ~timeout) dirs
84
+
let total = List.length dirs in
85
+
let bar = Tty.Progress.create ~total "Testing" in
86
+
let results =
87
+
List.map
88
+
(fun dir ->
89
+
Tty.Progress.update bar ~phase:"test" ~msg:dir;
90
+
run_test_eio ~process_mgr ~timeout dir)
91
+
dirs
92
+
in
93
+
Tty.Progress.finish bar;
94
+
results
76
95
77
96
let run timeout filter () =
78
97
Eio_main.run @@ fun env ->
79
98
let process_mgr = Eio.Stdenv.process_mgr env in
80
-
let dirs = find_test_dirs () in
99
+
let fs = Eio.Stdenv.fs env in
100
+
let dirs = find_test_dirs ~fs in
81
101
let dirs =
82
102
match filter with
83
103
| [] -> dirs
84
104
| fs -> List.filter (fun d -> List.mem d fs) dirs
85
105
in
86
106
Log.info (fun m -> m "Testing %d directories" (List.length dirs));
87
-
List.iter (fun d -> Log.info (fun m -> m " - %s" d)) dirs;
88
-
Log.info (fun m -> m "Pre-building test targets...");
89
-
prebuild ~process_mgr dirs;
90
-
Log.info (fun m -> m "Running tests sequentially (timeout: %ds)..." timeout);
91
-
let results = run_tests_sequential ~process_mgr ~timeout dirs in
107
+
List.iter (fun d -> Log.debug (fun m -> m " - %s" d)) dirs;
108
+
let build_failures = prebuild ~process_mgr ~timeout dirs in
109
+
let failed_dirs = List.map (fun r -> r.name) build_failures in
110
+
let testable_dirs =
111
+
List.filter (fun d -> not (List.mem d failed_dirs)) dirs
112
+
in
113
+
Log.info (fun m ->
114
+
m "Running tests on %d directories (timeout: %ds)..."
115
+
(List.length testable_dirs)
116
+
timeout);
117
+
let test_results = run_tests_sequential ~process_mgr ~timeout testable_dirs in
118
+
let results = build_failures @ test_results in
92
119
let pp_result r =
93
120
let status_str =
94
121
styled (status_style r.status) (status_to_string r.status)
···
98
125
List.iter pp_result results;
99
126
let slow = List.filter (fun r -> r.status = `Slow) results in
100
127
let fail =
101
-
List.filter (fun r -> r.status = `Fail || r.status = `Timeout) results
128
+
List.filter
129
+
(fun r ->
130
+
r.status = `Fail || r.status = `Timeout || r.status = `Build_fail)
131
+
results
102
132
in
103
133
Fmt.pr "@.";
104
134
if fail <> [] then
···
107
137
(List.length fail);
108
138
if slow <> [] then
109
139
Fmt.pr "%s %d tests slow (>2s)@."
110
-
(styled (status_style `Slow) "⚠")
140
+
(styled (status_style `Slow) "!")
111
141
(List.length slow);
112
142
if fail = [] && slow = [] then
113
143
Fmt.pr "%s All %d tests OK@."
···
122
152
`S Manpage.s_description;
123
153
`P
124
154
"Runs $(b,dune test) on each directory in the monorepo and reports \
125
-
which pass, fail, or are slow (>2s). Tests are prebuilt then run \
155
+
which pass, fail, or are slow (>2s). Each directory is built \
156
+
individually first to detect build failures, then tests are run \
126
157
sequentially.";
127
158
`S "EXAMPLES";
128
159
`Pre "monopam test";
160
+
`Pre "monopam test -vv";
129
161
`Pre "monopam test ocaml-qemu ocaml-bloom";
130
162
`Pre "monopam test --timeout 120";
131
163
]
132
164
in
133
165
let info = Cmd.info "test" ~doc ~man in
134
166
let timeout_arg =
135
-
let doc = "Timeout in seconds per test directory." in
167
+
let doc = "Timeout in seconds per build/test directory." in
136
168
Arg.(value & opt int 60 & info [ "timeout"; "t" ] ~docv:"SECONDS" ~doc)
137
169
in
138
170
let filter_arg =
+2
-2
lib/fork_join.ml
+2
-2
lib/fork_join.ml
···
854
854
let git_repo = Git.Repository.open_repo ~fs repo in
855
855
let commit = Git.Hash.of_hex hash_hex in
856
856
let user =
857
-
match Git_cli.global_git_user () with
857
+
match Git_cli.global_git_user ~fs () with
858
858
| Some u -> u
859
859
| None ->
860
860
Git.User.v ~name:"monopam" ~email:"monopam@localhost"
···
1154
1154
let git_repo = Git.Repository.open_repo ~fs monorepo in
1155
1155
let commit = Git.Hash.of_hex hash_hex in
1156
1156
let user =
1157
-
match Git_cli.global_git_user () with
1157
+
match Git_cli.global_git_user ~fs () with
1158
1158
| Some u -> u
1159
1159
| None ->
1160
1160
Git.User.v ~name:"monopam" ~email:"monopam@localhost"
+46
-64
lib/git_cli.ml
+46
-64
lib/git_cli.ml
···
1
1
let src = Logs.Src.create "monopam.git_cli" ~doc:"Git CLI operations"
2
2
3
-
(** Read user info from global git config. *)
4
-
let global_git_user () =
5
-
let read_config key =
6
-
let ic = Unix.open_process_in (Fmt.str "git config %s" key) in
7
-
let value =
8
-
try Some (String.trim (input_line ic)) with End_of_file -> None
9
-
in
10
-
ignore (Unix.close_process_in ic);
11
-
value
12
-
in
13
-
match (read_config "user.name", read_config "user.email") with
14
-
| Some name, Some email ->
15
-
let date = Int64.of_float (Unix.gettimeofday ()) in
16
-
Some (Git.User.v ~name ~email ~date ())
17
-
| _ -> None
18
-
19
3
type cmd_result = { exit_code : int; stdout : string; stderr : string }
20
4
21
5
type error =
···
69
53
if result.exit_code = 0 then Ok result.stdout
70
54
else Error (Command_failed (String.concat " " ("git" :: args), result))
71
55
72
-
(** Helper for substring check *)
73
-
let string_contains ~needle haystack =
74
-
let needle_len = String.length needle in
75
-
let haystack_len = String.length haystack in
76
-
if needle_len > haystack_len then false
77
-
else
78
-
let rec check i =
79
-
if i + needle_len > haystack_len then false
80
-
else if String.sub haystack i needle_len = needle then true
81
-
else check (i + 1)
82
-
in
83
-
check 0
56
+
(** Read user info from global git config (~/.gitconfig). *)
57
+
let global_git_user ~fs () =
58
+
let path = Eio.Path.(Xdge.home_dir fs / ".gitconfig") in
59
+
match Eio.Path.load path with
60
+
| content -> (
61
+
let config = Git.Config.of_string content in
62
+
let user = Git.Config.get_user config in
63
+
match (user.name, user.email) with
64
+
| Some name, Some email ->
65
+
let date = Int64.of_float (Unix.gettimeofday ()) in
66
+
Some (Git.User.v ~name ~email ~date ())
67
+
| _ -> None)
68
+
| exception Eio.Io _ -> None
84
69
85
-
(** Patterns indicating retryable HTTP 5xx or network errors *)
86
-
let retryable_error_patterns =
87
-
[
88
-
(* HTTP 5xx errors *)
89
-
"500";
90
-
"502";
91
-
"503";
92
-
"504";
93
-
"HTTP 5";
94
-
"http 5";
95
-
"Internal Server Error";
96
-
"Bad Gateway";
97
-
"Service Unavailable";
98
-
"Gateway Timeout";
99
-
(* RPC failures (common git smart HTTP errors) *)
100
-
"RPC failed";
101
-
"curl";
102
-
"unexpected disconnect";
103
-
"the remote end hung up";
104
-
"early EOF";
105
-
(* Connection errors *)
106
-
"Connection refused";
107
-
"Connection reset";
108
-
"Connection timed out";
109
-
"Could not resolve host";
110
-
"Failed to connect";
111
-
"Network is unreachable";
112
-
"Temporary failure";
113
-
]
70
+
(** Retryable HTTP 5xx and network error patterns, compiled once. *)
71
+
let retryable_re =
72
+
let open Re in
73
+
let patterns =
74
+
[
75
+
"500";
76
+
"502";
77
+
"503";
78
+
"504";
79
+
"HTTP 5";
80
+
"http 5";
81
+
"Internal Server Error";
82
+
"Bad Gateway";
83
+
"Service Unavailable";
84
+
"Gateway Timeout";
85
+
"RPC failed";
86
+
"curl";
87
+
"unexpected disconnect";
88
+
"the remote end hung up";
89
+
"early EOF";
90
+
"Connection refused";
91
+
"Connection reset";
92
+
"Connection timed out";
93
+
"Could not resolve host";
94
+
"Failed to connect";
95
+
"Network is unreachable";
96
+
"Temporary failure";
97
+
]
98
+
in
99
+
compile (alt (List.map str patterns))
114
100
115
101
(** Check if an error is a retryable HTTP server error (5xx) or network error *)
116
102
let is_retryable_error result =
117
-
let stderr = result.stderr in
118
-
String.length stderr > 0
119
-
&& List.exists
120
-
(fun needle -> string_contains ~needle stderr)
121
-
retryable_error_patterns
103
+
result.stderr <> "" && Re.execp retryable_re result.stderr
122
104
123
105
(** Run a git command with retry logic for network errors. Retries up to
124
106
[max_retries] times with exponential backoff starting at [initial_delay_ms].
···
157
139
match result with
158
140
| Ok _ -> Ok ()
159
141
| Error (Command_failed (_, r))
160
-
when string_contains ~needle:"Remote branch" r.stderr
161
-
&& string_contains ~needle:"not found" r.stderr ->
142
+
when Re.execp Re.(compile (str "Remote branch")) r.stderr
143
+
&& Re.execp Re.(compile (str "not found")) r.stderr ->
162
144
(* Empty remote repo - init locally and add remote *)
163
145
let target_dir = Eio.Path.(cwd / target_name) in
164
146
(try Eio.Path.mkdir ~perm:0o755 target_dir with Eio.Io _ -> ());
+2
-2
lib/git_cli.mli
+2
-2
lib/git_cli.mli
···
6
6
7
7
(** {1 User configuration} *)
8
8
9
-
val global_git_user : unit -> Git.User.t option
10
-
(** [global_git_user ()] reads user.name and user.email from global git config.
9
+
val global_git_user : fs:Eio.Fs.dir_ty Eio.Path.t -> unit -> Git.User.t option
10
+
(** [global_git_user ~fs ()] reads user.name and user.email from [~/.gitconfig].
11
11
Returns [None] if either is not configured. *)
12
12
13
13
(** {1 Types} *)
+1
-1
lib/init.ml
+1
-1
lib/init.ml
-4
lib/monopam.ml
-4
lib/monopam.ml
-9
lib/monopam.mli
-9
lib/monopam.mli
···
136
136
?refresh:bool ->
137
137
unit ->
138
138
(cherrypick_result, Ctx.error) result
139
-
140
-
val sync_opam_files :
141
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
142
-
config:Config.t ->
143
-
?packages:string list ->
144
-
unit ->
145
-
(Opam_sync.t, [ `Config_error of string ]) result
146
-
147
-
val pp_opam_sync_result : Format.formatter -> Opam_sync.t -> unit
+2
-2
lib/opam_sync.ml
+2
-2
lib/opam_sync.ml
···
176
176
if result.synced <> [] || result.orphaned <> [] then begin
177
177
let repo = Git.Repository.open_repo ~fs opam_repo in
178
178
let msg = commit_message result in
179
-
match Git_cli.global_git_user () with
179
+
match Git_cli.global_git_user ~fs () with
180
180
| Some user -> (
181
181
match
182
182
Git.Repository.commit_index repo ~author:user ~committer:user
···
356
356
then begin
357
357
let repo = Git.Repository.open_repo ~fs target in
358
358
let msg = commit_message result in
359
-
match Git_cli.global_git_user () with
359
+
match Git_cli.global_git_user ~fs () with
360
360
| Some user -> (
361
361
match
362
362
Git.Repository.commit_index repo ~author:user ~committer:user
+1
-1
lib/pull.ml
+1
-1
lib/pull.ml
···
32
32
let git_repo = Git.Repository.open_repo ~fs monorepo in
33
33
let commit = Git.Hash.of_hex hash_hex in
34
34
let user =
35
-
match Git_cli.global_git_user () with
35
+
match Git_cli.global_git_user ~fs () with
36
36
| Some u -> u
37
37
| None ->
38
38
Git.User.v ~name:"monopam" ~email:"monopam@localhost"