jon.recoil.org
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
5let app_name = "monopam"
6
7(** {1 Package Overrides} *)
8
9module Package_config = struct
10 type t = { branch : string option }
11
12 let branch t = t.branch
13
14 let codec : t Tomlt.t =
15 Tomlt.(
16 Table.(
17 obj (fun branch -> { branch })
18 |> opt_mem "branch" string ~enc:(fun c -> c.branch)
19 |> finish))
20end
21
22(** {1 Paths Configuration} *)
23
24type paths = {
25 mono : string; (** Monorepo directory (default: "mono") *)
26 src : string; (** Source checkouts directory (default: "src") *)
27 verse : string; (** Verse directory (default: "verse") *)
28}
29
30let default_paths = { mono = "mono"; src = "src"; verse = "verse" }
31
32(** {1 Main Configuration Type} *)
33
34type t = {
35 (* Workspace structure *)
36 root : Fpath.t;
37 paths : paths;
38 (* Identity *)
39 handle : string;
40 knot : string; (** Git push server hostname (e.g., "git.recoil.org") *)
41 (* Package overrides *)
42 packages : (string * Package_config.t) list;
43}
44
45(** {1 Accessors} *)
46
47let root t = t.root
48let handle t = t.handle
49let knot t = t.knot
50let paths t = t.paths
51let packages t = t.packages
52let package_config t name = List.assoc_opt name t.packages
53
54(* Derived paths *)
55let default_branch = "main"
56let mono_path t = Fpath.(t.root / t.paths.mono)
57let src_path t = Fpath.(t.root / t.paths.src)
58let opam_repo_path t = Fpath.(t.root / "opam-repo")
59let verse_path t = Fpath.(t.root / t.paths.verse)
60
61(* Aliases for backwards compatibility with old Config.Paths module *)
62module Paths = struct
63 let opam_repo = opam_repo_path
64 let checkouts = src_path
65 let monorepo = mono_path
66end
67
68(** {1 XDG Paths} *)
69
70let xdg_config_home () =
71 match Sys.getenv_opt "XDG_CONFIG_HOME" with
72 | Some dir when dir <> "" -> Fpath.v dir
73 | _ -> (
74 match Sys.getenv_opt "HOME" with
75 | Some home -> Fpath.(v home / ".config")
76 | None -> Fpath.v "/tmp")
77
78let xdg_data_home () =
79 match Sys.getenv_opt "XDG_DATA_HOME" with
80 | Some dir when dir <> "" -> Fpath.v dir
81 | _ -> (
82 match Sys.getenv_opt "HOME" with
83 | Some home -> Fpath.(v home / ".local" / "share")
84 | None -> Fpath.v "/tmp")
85
86let xdg_cache_home () =
87 match Sys.getenv_opt "XDG_CACHE_HOME" with
88 | Some dir when dir <> "" -> Fpath.v dir
89 | _ ->
90 match Sys.getenv_opt "HOME" with
91 | Some home -> Fpath.(v home / ".cache")
92 | None -> Fpath.v "/tmp"
93
94let config_dir () = Fpath.(xdg_config_home () / app_name)
95let data_dir () = Fpath.(xdg_data_home () / app_name)
96let cache_dir () = Fpath.(xdg_cache_home () / app_name)
97let config_file () = Fpath.(config_dir () / "opamverse.toml")
98let registry_path () = Fpath.(data_dir () / "opamverse-registry")
99
100(** {1 Construction} *)
101
102(** Derive knot (git push server) from handle.
103 E.g., "anil.recoil.org" -> "git.recoil.org" *)
104let default_knot_from_handle handle =
105 match String.index_opt handle '.' with
106 | None -> "git." ^ handle (* fallback *)
107 | Some i ->
108 let domain = String.sub handle (i + 1) (String.length handle - i - 1) in
109 "git." ^ domain
110
111let 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 { root; handle; knot; packages; paths }
114
115let with_package_override t ~name ?branch:branch_opt () =
116 let existing = List.assoc_opt name t.packages in
117 let existing_branch = Option.bind existing Package_config.branch in
118 let new_branch =
119 match branch_opt with Some _ -> branch_opt | None -> existing_branch
120 in
121 let pkg_config = Package_config.{ branch = new_branch } in
122 let packages = (name, pkg_config) :: List.remove_assoc name t.packages in
123 { t with packages }
124
125(** {1 TOML Codecs} *)
126
127let expand_tilde s =
128 if String.length s > 0 && s.[0] = '~' then
129 match Sys.getenv_opt "HOME" with
130 | Some home ->
131 if String.length s = 1 then home
132 else if s.[1] = '/' then home ^ String.sub s 1 (String.length s - 1)
133 else s
134 | None -> s
135 else s
136
137let fpath_codec : Fpath.t Tomlt.t =
138 Tomlt.map
139 ~dec:(fun s ->
140 let s = expand_tilde s in
141 match Fpath.of_string s with Ok p -> p | Error (`Msg m) -> failwith m)
142 ~enc:Fpath.to_string Tomlt.string
143
144let paths_codec : paths Tomlt.t =
145 Tomlt.(
146 Table.(
147 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 |> opt_mem "mono" string ~enc:(fun p -> Some p.mono)
152 |> opt_mem "src" string ~enc:(fun p -> Some p.src)
153 |> opt_mem "verse" string ~enc:(fun p -> Some p.verse)
154 |> finish))
155
156(* TOML structure:
157 [workspace]
158 root = "~/tangled"
159
160 [identity]
161 handle = "anil.recoil.org"
162 knot = "git.recoil.org"
163
164 [paths]
165 mono = "mono"
166 src = "src"
167
168 [packages.braid]
169 branch = "backport-fix"
170*)
171
172type workspace_section = { w_root : Fpath.t }
173type identity_section = { i_handle : string; i_knot : string option }
174
175let default_knot = "git.recoil.org"
176
177let workspace_codec : workspace_section Tomlt.t =
178 Tomlt.(
179 Table.(
180 obj (fun w_root -> { w_root })
181 |> mem "root" fpath_codec ~enc:(fun w -> w.w_root)
182 |> finish))
183
184let identity_codec : identity_section Tomlt.t =
185 Tomlt.(
186 Table.(
187 obj (fun i_handle i_knot -> { i_handle; i_knot })
188 |> mem "handle" string ~enc:(fun i -> i.i_handle)
189 |> opt_mem "knot" string ~enc:(fun i -> i.i_knot)
190 |> finish))
191
192(* Codec for the [packages] table which contains subtree->override mappings *)
193let packages_table_codec : (string * Package_config.t) list Tomlt.t =
194 Tomlt.(
195 Table.(
196 obj (fun pkgs -> pkgs)
197 |> keep_unknown ~enc:(fun pkgs -> pkgs)
198 (Mems.assoc Package_config.codec)
199 |> finish))
200
201let codec : t Tomlt.t =
202 Tomlt.(
203 Table.(
204 obj (fun workspace identity packages paths ->
205 let packages = Option.value ~default:[] packages in
206 let paths = Option.value ~default:default_paths paths in
207 let knot = Option.value ~default:default_knot identity.i_knot in
208 { root = workspace.w_root; handle = identity.i_handle; knot; packages; paths })
209 |> 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)
215 |> finish))
216
217(** {1 Validation} *)
218
219type validation_error =
220 | Path_not_found of string * Fpath.t
221 | Not_a_directory of string * Fpath.t
222 | Not_an_opam_repo of Fpath.t
223 | Invalid_path of string * string
224 | Relative_path of string * Fpath.t
225
226let pp_validation_error ppf = function
227 | Path_not_found (field, path) ->
228 Fmt.pf ppf "%s path does not exist: %a" field Fpath.pp path
229 | Not_a_directory (field, path) ->
230 Fmt.pf ppf "%s path is not a directory: %a" field Fpath.pp path
231 | Not_an_opam_repo path ->
232 Fmt.pf ppf
233 "opam_repo is not a valid opam repository (missing packages/ \
234 directory): %a"
235 Fpath.pp path
236 | Invalid_path (field, msg) -> Fmt.pf ppf "%s has invalid path: %s" field msg
237 | Relative_path (field, path) ->
238 Fmt.pf ppf
239 "%s must be an absolute path, got: %a\n\
240 Hint: Use an absolute path starting with / or ~/"
241 field Fpath.pp path
242
243(** {1 Loading and Saving} *)
244
245let load ~fs () =
246 let path = config_file () in
247 let path_str = Fpath.to_string path in
248 let eio_path = Eio.Path.(fs / path_str) in
249 match Eio.Path.kind ~follow:true eio_path with
250 | `Regular_file -> (
251 try Ok (Tomlt_eio.decode_path_exn codec ~fs path_str) with
252 | Failure msg -> Error (Printf.sprintf "Invalid config: %s" msg)
253 | exn -> Error (Printf.sprintf "Error loading config: %s" (Printexc.to_string exn)))
254 | _ -> Error (Printf.sprintf "Config file not found: %s" path_str)
255 | exception _ -> Error (Printf.sprintf "Config file not found: %s" path_str)
256
257let save ~fs t =
258 let dir = config_dir () in
259 let path = config_file () in
260 try
261 (* Ensure XDG config directory exists *)
262 let dir_path = Eio.Path.(fs / Fpath.to_string dir) in
263 (try Eio.Path.mkdirs ~perm:0o755 dir_path with Eio.Io _ -> ());
264 Tomlt_eio.encode_path codec t ~fs (Fpath.to_string path);
265 Ok ()
266 with Eio.Io _ as e -> Error (Printexc.to_string e)
267
268(** {1 Pretty Printing} *)
269
270let pp ppf t =
271 Fmt.pf ppf
272 "@[<v>@[<hov 2>workspace:@ root=%a@]@,\
273 @[<hov 2>identity:@ handle=%s@ knot=%s@]@,\
274 @[<hov 2>paths:@ mono=%s@ src=%s@ verse=%s@]@,\
275 packages=%d@]"
276 Fpath.pp t.root t.handle t.knot
277 t.paths.mono t.paths.src t.paths.verse
278 (List.length t.packages)