forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
1(** Unified configuration for monopam.
2
3 Configuration is stored in TOML format at ~/.config/monopam/opamverse.toml
4*)
5
6(** {1 Error Helpers} *)
7
8let app_name = "monopam"
9
10(** {1 Package Overrides} *)
11
12module Package_config = struct
13 type t = { branch : string option }
14
15 let branch t = t.branch
16
17 let codec : t Toml.codec =
18 let open Toml.Codec in
19 Table.obj (fun branch -> { branch })
20 |> Table.opt_mem "branch" string ~enc:(fun c -> c.branch)
21 |> Table.finish
22end
23
24(** {1 Paths Configuration} *)
25
26type paths = {
27 mono : string; (** Monorepo directory (default: "mono") *)
28 src : string; (** Source checkouts directory (default: "src") *)
29 verse : string; (** Verse directory (default: "verse") *)
30}
31
32let default_paths = { mono = "mono"; src = "src"; verse = "verse" }
33
34(** {1 Main Configuration Type} *)
35
36type t = {
37 (* Workspace structure *)
38 root : Fpath.t;
39 paths : paths;
40 (* Identity *)
41 handle : string;
42 knot : string; (** Git push server hostname (e.g., "git.recoil.org") *)
43 (* Package overrides *)
44 packages : (string * Package_config.t) list;
45}
46
47(** {1 Accessors} *)
48
49let root t = t.root
50let handle t = t.handle
51let knot t = t.knot
52let paths t = t.paths
53let packages t = t.packages
54let package_config t name = List.assoc_opt name t.packages
55
56(* Derived paths *)
57let default_branch = "main"
58let mono_path t = Fpath.(t.root / t.paths.mono)
59let src_path t = Fpath.(t.root / t.paths.src)
60let opam_repo_path t = Fpath.(t.root / "opam-repo")
61let verse_path t = Fpath.(t.root / t.paths.verse)
62
63(* Aliases for backwards compatibility with old Config.Paths module *)
64module Paths = struct
65 let opam_repo = opam_repo_path
66 let checkouts = src_path
67 let monorepo = mono_path
68end
69
70(** {1 XDG Paths} *)
71
72let xdg_config_home () =
73 match Sys.getenv_opt "XDG_CONFIG_HOME" with
74 | Some dir when dir <> "" -> Fpath.v dir
75 | _ -> (
76 match Sys.getenv_opt "HOME" with
77 | Some home -> Fpath.(v home / ".config")
78 | None -> Fpath.v "/tmp")
79
80let xdg_data_home () =
81 match Sys.getenv_opt "XDG_DATA_HOME" with
82 | Some dir when dir <> "" -> Fpath.v dir
83 | _ -> (
84 match Sys.getenv_opt "HOME" with
85 | Some home -> Fpath.(v home / ".local" / "share")
86 | None -> Fpath.v "/tmp")
87
88let xdg_cache_home () =
89 match Sys.getenv_opt "XDG_CACHE_HOME" with
90 | Some dir when dir <> "" -> Fpath.v dir
91 | _ -> (
92 match Sys.getenv_opt "HOME" with
93 | Some home -> Fpath.(v home / ".cache")
94 | None -> Fpath.v "/tmp")
95
96let dir () = Fpath.(xdg_config_home () / app_name)
97let data_dir () = Fpath.(xdg_data_home () / app_name)
98let cache_dir () = Fpath.(xdg_cache_home () / app_name)
99let file () = Fpath.(dir () / "opamverse.toml")
100let registry_path () = Fpath.(data_dir () / "opamverse-registry")
101
102(** {1 Construction} *)
103
104let default_knot = "git.recoil.org"
105
106let v ~root ~handle ?(knot = default_knot) ?(packages = [])
107 ?(paths = default_paths) () =
108 { root; handle; knot; packages; paths }
109
110let with_package_override t ~name ?branch:branch_opt () =
111 let existing = List.assoc_opt name t.packages in
112 let existing_branch = Option.bind existing Package_config.branch in
113 let new_branch =
114 match branch_opt with Some _ -> branch_opt | None -> existing_branch
115 in
116 let pkg_config = Package_config.{ branch = new_branch } in
117 let packages = (name, pkg_config) :: List.remove_assoc name t.packages in
118 { t with packages }
119
120(** {1 TOML Codecs} *)
121
122let expand_tilde s =
123 if String.length s > 0 && s.[0] = '~' then
124 match Sys.getenv_opt "HOME" with
125 | Some home ->
126 if String.length s = 1 then home
127 else if s.[1] = '/' then home ^ String.sub s 1 (String.length s - 1)
128 else s
129 | None -> s
130 else s
131
132let fpath_codec : Fpath.t Toml.codec =
133 Toml.Codec.map
134 ~dec:(fun s ->
135 let s = expand_tilde s in
136 match Fpath.of_string s with Ok p -> p | Error (`Msg m) -> failwith m)
137 ~enc:Fpath.to_string Toml.Codec.string
138
139let paths_codec : paths Toml.codec =
140 let open Toml.Codec in
141 Table.obj (fun mono src verse ->
142 {
143 mono = Option.value ~default:default_paths.mono mono;
144 src = Option.value ~default:default_paths.src src;
145 verse = Option.value ~default:default_paths.verse verse;
146 })
147 |> Table.opt_mem "mono" string ~enc:(fun p -> Some p.mono)
148 |> Table.opt_mem "src" string ~enc:(fun p -> Some p.src)
149 |> Table.opt_mem "verse" string ~enc:(fun p -> Some p.verse)
150 |> Table.finish
151
152(* TOML structure:
153 [workspace]
154 root = "~/tangled"
155
156 [identity]
157 handle = "anil.recoil.org"
158 knot = "git.recoil.org"
159
160 [paths]
161 mono = "mono"
162 src = "src"
163
164 [packages.braid]
165 branch = "backport-fix"
166*)
167
168type workspace_section = { w_root : Fpath.t }
169type identity_section = { i_handle : string; i_knot : string }
170
171let workspace_codec : workspace_section Toml.codec =
172 let open Toml.Codec in
173 Table.obj (fun w_root -> { w_root })
174 |> Table.mem "root" fpath_codec ~enc:(fun w -> w.w_root)
175 |> Table.finish
176
177let identity_codec : identity_section Toml.codec =
178 let open Toml.Codec in
179 Table.obj (fun i_handle i_knot -> { i_handle; i_knot })
180 |> Table.mem "handle" string ~enc:(fun i -> i.i_handle)
181 |> Table.mem "knot" string ~enc:(fun i -> i.i_knot)
182 |> Table.finish
183
184(* Codec for the [packages] table which contains subtree->override mappings *)
185let packages_table_codec : (string * Package_config.t) list Toml.codec =
186 let open Toml.Codec in
187 Table.obj (fun pkgs -> pkgs)
188 |> Table.keep_unknown
189 ~enc:(fun pkgs -> pkgs)
190 (Table.Mems.assoc Package_config.codec)
191 |> Table.finish
192
193let codec : t Toml.codec =
194 let open Toml.Codec in
195 Table.obj (fun workspace identity packages paths ->
196 let packages = Option.value ~default:[] packages in
197 let paths = Option.value ~default:default_paths paths in
198 let knot = identity.i_knot in
199 {
200 root = workspace.w_root;
201 handle = identity.i_handle;
202 knot;
203 packages;
204 paths;
205 })
206 |> Table.mem "workspace" workspace_codec ~enc:(fun t -> { w_root = t.root })
207 |> Table.mem "identity" identity_codec ~enc:(fun t ->
208 { i_handle = t.handle; i_knot = t.knot })
209 |> Table.opt_mem "packages" packages_table_codec ~enc:(fun t ->
210 if t.packages = [] then None else Some t.packages)
211 |> Table.opt_mem "paths" paths_codec ~enc:(fun t ->
212 if t.paths = default_paths then None else Some t.paths)
213 |> Table.finish
214
215(** {1 Validation} *)
216
217type validation_error =
218 | Path_not_found of string * Fpath.t
219 | Not_a_directory of string * Fpath.t
220 | Not_an_opam_repo of Fpath.t
221 | Invalid_path of string * string
222 | Relative_path of string * Fpath.t
223
224let pp_validation_error ppf = function
225 | Path_not_found (field, path) ->
226 Fmt.pf ppf "%s path does not exist: %a" field Fpath.pp path
227 | Not_a_directory (field, path) ->
228 Fmt.pf ppf "%s path is not a directory: %a" field Fpath.pp path
229 | Not_an_opam_repo path ->
230 Fmt.pf ppf
231 "opam_repo is not a valid opam repository (missing packages/ \
232 directory): %a"
233 Fpath.pp path
234 | Invalid_path (field, msg) -> Fmt.pf ppf "%s has invalid path: %s" field msg
235 | Relative_path (field, path) ->
236 Fmt.pf ppf
237 "%s must be an absolute path, got: %a\n\
238 Hint: Use an absolute path starting with / or ~/"
239 field Fpath.pp path
240
241(** {1 Loading and Saving} *)
242
243type load_error =
244 | Not_found of Fpath.t
245 | Invalid of { path : Fpath.t; msg : string }
246 | Io_error of { path : Fpath.t; msg : string }
247
248let pp_load_error ppf = function
249 | Not_found path -> Fmt.pf ppf "Config file not found: %a" Fpath.pp path
250 | Invalid { path; msg } ->
251 Fmt.pf ppf "Invalid config at %a: %s" Fpath.pp path msg
252 | Io_error { path; msg } ->
253 Fmt.pf ppf "Error reading config at %a: %s" Fpath.pp path msg
254
255(** Walk up from [start] looking for an [opamverse.toml] file. Returns the first
256 one found, or [None] when we hit the filesystem root. Used so a developer
257 with multiple monopam workspaces on one machine can [cd] into any of them
258 and have the tool pick up THAT workspace's config without needing to swap
259 [$HOME] or any global state. *)
260let workspace_config ~fs start =
261 let exists path =
262 let eio_path = Eio.Path.(fs / Fpath.to_string path) in
263 match Eio.Path.kind ~follow:true eio_path with
264 | `Regular_file -> true
265 | _ -> false
266 | exception _ -> false
267 in
268 let rec walk dir =
269 let candidate = Fpath.(dir / "opamverse.toml") in
270 if exists candidate then Some candidate
271 else
272 let parent = Fpath.parent dir in
273 if Fpath.equal parent dir then None else walk parent
274 in
275 walk (Fpath.normalize start)
276
277let load_path ~fs path =
278 let path_str = Fpath.to_string path in
279 let eio_path = Eio.Path.(fs / path_str) in
280 match Eio.Path.kind ~follow:true eio_path with
281 | `Regular_file -> (
282 try Ok (Toml_eio.decode_path_exn codec ~fs path_str) with
283 | Failure msg -> Error (Invalid { path; msg })
284 | exn -> Error (Io_error { path; msg = Printexc.to_string exn }))
285 | _ -> Error (Not_found path)
286 | exception _ -> Error (Not_found path)
287
288let load ~fs () =
289 (* First, walk up from CWD looking for a per-workspace
290 opamverse.toml. This is the multi-workspace path: each app has
291 its own config and its own root, with no need to swap HOME or
292 XDG. If nothing is found we fall back to the XDG global config
293 so single-workspace users keep working as before. *)
294 let cwd = Fpath.v (Sys.getcwd ()) in
295 match workspace_config ~fs cwd with
296 | Some path -> load_path ~fs path
297 | None -> load_path ~fs (file ())
298
299let save ~fs t =
300 let dir = dir () in
301 let path = file () in
302 try
303 (* Ensure XDG config directory exists *)
304 let dir_path = Eio.Path.(fs / Fpath.to_string dir) in
305 (try Eio.Path.mkdirs ~perm:0o755 dir_path with Eio.Io _ -> ());
306 Toml_eio.encode_path codec t ~fs (Fpath.to_string path);
307 Ok ()
308 with Eio.Io _ as e -> Error (Printexc.to_string e)
309
310(** {1 Pretty Printing} *)
311
312let pp ppf t =
313 Fmt.pf ppf
314 "@[<v>@[<hov 2>workspace:@ root=%a@]@,\
315 @[<hov 2>identity:@ handle=%s@ knot=%s@]@,\
316 @[<hov 2>paths:@ mono=%s@ src=%s@ verse=%s@]@,\
317 packages=%d@]"
318 Fpath.pp t.root t.handle t.knot t.paths.mono t.paths.src t.paths.verse
319 (List.length t.packages)