My aggregated monorepo of OCaml code, automaintained
Squashed 'poe/' changes from c1a05c5..904a31d
904a31d Use dev-repo URLs from opam metadata for changelog package links
6fb511b Add structured JSON changelog output with repo links and verse support
402c4c6 Add debug logging for git commands in poe loop
git-subtree-dir: poe
git-subtree-split: 904a31d0c3b8b3fee88e3718dcbd90b982bcf491
+440
-132
+1
-1
bin/main.ml
+1
-1
bin/main.ml
···
148
148
let members = Poe.Changelog.get_channel_members ~client ~channel:poe_config.channel in
149
149
150
150
(* Generate narrative changelog with Claude *)
151
-
match Poe.Changelog.generate ~sw ~proc ~clock ~commits ~members with
151
+
match Poe.Changelog.generate ~sw ~proc ~clock ~fs ~commits ~members () with
152
152
| None ->
153
153
Logs.err (fun m -> m "Could not generate changelog")
154
154
| Some content ->
+13
lib/admin.ml
+13
lib/admin.ml
···
6
6
let last_broadcast_key = "poe:broadcast:last_time"
7
7
let last_git_head_key = "poe:broadcast:last_git_head"
8
8
9
+
(* Per-user git head keys for verse members *)
10
+
let user_git_head_key handle = Printf.sprintf "poe:broadcast:git_head:%s" handle
11
+
9
12
let get_last_broadcast_time storage =
10
13
match Zulip_bot.Storage.get storage last_broadcast_key with
11
14
| None -> None
···
27
30
28
31
let set_last_git_head storage hash =
29
32
Zulip_bot.Storage.set storage last_git_head_key hash
33
+
34
+
(* Per-user git HEAD tracking for verse members *)
35
+
let get_user_git_head storage ~handle =
36
+
match Zulip_bot.Storage.get storage (user_git_head_key handle) with
37
+
| None -> None
38
+
| Some s when s = "" -> None
39
+
| Some s -> Some s
40
+
41
+
let set_user_git_head storage ~handle hash =
42
+
Zulip_bot.Storage.set storage (user_git_head_key handle) hash
30
43
31
44
let format_time_option = function
32
45
| None -> "never"
+10
lib/admin.mli
+10
lib/admin.mli
···
32
32
val set_last_git_head : Zulip_bot.Storage.t -> string -> unit
33
33
(** [set_last_git_head storage hash] stores the git HEAD in storage. *)
34
34
35
+
(** {2 Per-User Git HEAD Tracking} *)
36
+
37
+
val get_user_git_head : Zulip_bot.Storage.t -> handle:string -> string option
38
+
(** [get_user_git_head storage ~handle] retrieves the last seen git HEAD
39
+
for a specific verse user. *)
40
+
41
+
val set_user_git_head : Zulip_bot.Storage.t -> handle:string -> string -> unit
42
+
(** [set_user_git_head storage ~handle hash] stores the git HEAD for a
43
+
specific verse user. *)
44
+
35
45
(** {1 Command Handlers} *)
36
46
37
47
val handle : storage:Zulip_bot.Storage.t -> Commands.admin_command -> string
+1
-1
lib/broadcast.ml
+1
-1
lib/broadcast.ml
···
40
40
let members = Changelog.get_channel_members ~client ~channel:config.Config.channel in
41
41
42
42
(* Generate narrative changelog with Claude *)
43
-
match Changelog.generate ~sw ~proc ~clock ~commits ~members with
43
+
match Changelog.generate ~sw ~proc ~clock ~fs ~commits ~members () with
44
44
| None ->
45
45
Zulip_bot.Response.reply "Could not generate changelog."
46
46
| Some content ->
+134
-24
lib/changelog.ml
+134
-24
lib/changelog.ml
···
13
13
author: string;
14
14
email: string;
15
15
subject: string;
16
+
date: string;
16
17
files: string list;
17
18
}
18
19
···
21
22
email: string;
22
23
}
23
24
25
+
type changelog_item = {
26
+
project: string;
27
+
description: string;
28
+
change_type: string;
29
+
}
30
+
31
+
type changelog_response = {
32
+
items: changelog_item list;
33
+
}
34
+
35
+
let changelog_item_codec : changelog_item Jsont.t =
36
+
Jsont.Object.map
37
+
~kind:"changelog_item"
38
+
(fun project description change_type -> { project; description; change_type })
39
+
|> Jsont.Object.mem "project" Jsont.string ~enc:(fun i -> i.project)
40
+
|> Jsont.Object.mem "description" Jsont.string ~enc:(fun i -> i.description)
41
+
|> Jsont.Object.mem "change_type" Jsont.string ~enc:(fun i -> i.change_type)
42
+
|> Jsont.Object.finish
43
+
44
+
let changelog_response_codec : changelog_response Jsont.t =
45
+
Jsont.Object.map
46
+
~kind:"changelog_response"
47
+
(fun items -> { items })
48
+
|> Jsont.Object.mem "items" (Jsont.list changelog_item_codec) ~enc:(fun r -> r.items)
49
+
|> Jsont.Object.finish
50
+
24
51
let get_commit_files ~proc ~cwd ~hash =
52
+
let cmd = ["git"; "diff-tree"; "--no-commit-id"; "--name-only"; "-r"; hash] in
53
+
Log.debug (fun m -> m "Running: %s (in %s)" (String.concat " " cmd) (Eio.Path.native_exn cwd));
25
54
Eio.Switch.run @@ fun sw ->
26
55
let buf = Buffer.create 256 in
27
56
let child = Eio.Process.spawn proc ~sw ~cwd
28
57
~stdout:(Eio.Flow.buffer_sink buf)
29
-
["git"; "diff-tree"; "--no-commit-id"; "--name-only"; "-r"; hash]
58
+
cmd
30
59
in
31
60
match Eio.Process.await child with
32
61
| `Exited 0 ->
···
37
66
38
67
let get_git_log ~proc ~cwd ~since_head =
39
68
Log.info (fun m -> m "Getting commits since %s" since_head);
69
+
let cmd = ["git"; "log"; "--pretty=format:%h|%an|%ae|%s|%ci"; since_head ^ "..HEAD"] in
70
+
Log.debug (fun m -> m "Running: %s (in %s)" (String.concat " " cmd) (Eio.Path.native_exn cwd));
40
71
Eio.Switch.run @@ fun sw ->
41
72
let buf = Buffer.create 1024 in
42
73
let child = Eio.Process.spawn proc ~sw ~cwd
43
74
~stdout:(Eio.Flow.buffer_sink buf)
44
-
["git"; "log"; "--pretty=format:%h|%an|%ae|%s"; since_head ^ "..HEAD"]
75
+
cmd
45
76
in
46
77
match Eio.Process.await child with
47
78
| `Exited 0 ->
···
51
82
String.split_on_char '\n' output
52
83
|> List.filter_map (fun line ->
53
84
match String.split_on_char '|' line with
54
-
| [hash; author; email; subject] ->
85
+
| [hash; author; email; subject; date] ->
55
86
let files = get_commit_files ~proc ~cwd ~hash in
56
-
Some { hash; author; email; subject; files }
87
+
Some { hash; author; email; subject; date; files }
57
88
| _ -> None)
58
89
| _ -> []
59
90
60
91
let get_recent_commits ~proc ~cwd ~count =
61
92
Log.info (fun m -> m "Getting last %d commits" count);
93
+
let cmd = ["git"; "log"; "--pretty=format:%h|%an|%ae|%s|%ci"; "-n"; string_of_int count] in
94
+
Log.debug (fun m -> m "Running: %s (in %s)" (String.concat " " cmd) (Eio.Path.native_exn cwd));
62
95
Eio.Switch.run @@ fun sw ->
63
96
let buf = Buffer.create 1024 in
64
97
let child = Eio.Process.spawn proc ~sw ~cwd
65
98
~stdout:(Eio.Flow.buffer_sink buf)
66
-
["git"; "log"; "--pretty=format:%h|%an|%ae|%s"; "-n"; string_of_int count]
99
+
cmd
67
100
in
68
101
match Eio.Process.await child with
69
102
| `Exited 0 ->
···
73
106
String.split_on_char '\n' output
74
107
|> List.filter_map (fun line ->
75
108
match String.split_on_char '|' line with
76
-
| [hash; author; email; subject] ->
109
+
| [hash; author; email; subject; date] ->
77
110
let files = get_commit_files ~proc ~cwd ~hash in
78
-
Some { hash; author; email; subject; files }
111
+
Some { hash; author; email; subject; date; files }
79
112
| _ -> None)
80
113
| _ -> []
81
114
···
133
166
|> List.filter_map subproject_of_file
134
167
|> List.sort_uniq String.compare
135
168
136
-
let generate ~sw ~proc ~clock ~commits ~members =
169
+
(* Get most recent commit date from a list of commits *)
170
+
let most_recent_date commits =
171
+
match commits with
172
+
| [] -> None
173
+
| commits ->
174
+
let dates = List.map (fun c -> c.date) commits in
175
+
(* Dates are in ISO format, so string comparison works *)
176
+
Some (List.fold_left max "" dates)
177
+
178
+
(* Extract just the date part from git date string (YYYY-MM-DD from "YYYY-MM-DD HH:MM:SS +ZZZZ") *)
179
+
let date_only s =
180
+
match String.split_on_char ' ' s with
181
+
| d :: _ -> d
182
+
| [] -> s
183
+
184
+
(* Parse JSON response from Claude, with fallback to raw text *)
185
+
let parse_changelog_json json_str =
186
+
match Jsont_bytesrw.decode_string changelog_response_codec json_str with
187
+
| Ok response -> Ok response.items
188
+
| Error e ->
189
+
Log.warn (fun m -> m "Failed to parse JSON response: %s" e);
190
+
Error e
191
+
192
+
(* Build a map from package name to dev-repo URL by scanning the opam repo *)
193
+
let build_package_url_map ~fs ~opamrepo_path =
194
+
match opamrepo_path with
195
+
| None -> Hashtbl.create 0
196
+
| Some path ->
197
+
let map = Hashtbl.create 16 in
198
+
let packages, _errors = Monopam.Opam_repo.scan_all ~fs path in
199
+
List.iter (fun pkg ->
200
+
let name = Monopam.Package.name pkg in
201
+
let dev_repo = Monopam.Package.dev_repo pkg in
202
+
(* Convert git URL to browsable HTTPS URL *)
203
+
let url = Uri.to_string dev_repo in
204
+
(* Remove trailing .git if present *)
205
+
let url = if String.ends_with ~suffix:".git" url
206
+
then String.sub url 0 (String.length url - 4)
207
+
else url
208
+
in
209
+
Hashtbl.replace map name url
210
+
) packages;
211
+
map
212
+
213
+
(* Format a changelog item as a markdown bullet with repo link *)
214
+
let format_item ~package_urls item =
215
+
let project_link = match Hashtbl.find_opt package_urls item.project with
216
+
| Some url ->
217
+
(* Link to the actual project repository *)
218
+
Printf.sprintf "[%s](%s)" item.project url
219
+
| None -> item.project
220
+
in
221
+
Printf.sprintf "- **%s**: %s *%s*" project_link item.description item.change_type
222
+
223
+
let generate ~sw ~proc ~clock ~fs ~commits ~members ?opamrepo_path () =
137
224
if commits = [] then None
138
225
else begin
139
226
Log.info (fun m -> m "Generating narrative changelog with Claude for %d commits" (List.length commits));
227
+
228
+
(* Build package URL map from opam repo *)
229
+
let package_urls = build_package_url_map ~fs ~opamrepo_path in
140
230
141
231
(* Get affected sub-projects *)
142
232
let subprojects = affected_subprojects commits in
···
173
263
174
264
%s
175
265
176
-
Write a bullet-point changelog. Each bullet should have the project name first in bold, then a brief description of the change, and the change type in italics at the end.
266
+
Write a changelog as a JSON object with an "items" array. Each item should have:
267
+
- "project": the project/package name (string)
268
+
- "description": description of the change, may include @**Name** mentions (string)
269
+
- "change_type": one of "new feature", "bug fix", "enhancement", "refactoring", "documentation", etc. (string)
177
270
178
-
Format:
179
-
- **project-name**: Description of the change. *change type*
180
-
181
-
Example:
182
-
- **ocaml-claudeio**: Added model types for Opus 4.5 and 4.1. *new feature*
183
-
- **ocaml-zulip**: Fixed encoding bug in channel name lookups that affected names with spaces. *bug fix*
184
-
- **poe**: Updated to use the latest Opus model for changelog generation. *enhancement*
271
+
Example output:
272
+
```json
273
+
{
274
+
"items": [
275
+
{"project": "ocaml-claudeio", "description": "Added model types for Opus 4.5 and 4.1.", "change_type": "new feature"},
276
+
{"project": "ocaml-zulip", "description": "Fixed encoding bug in channel name lookups that affected names with spaces.", "change_type": "bug fix"}
277
+
]
278
+
}
279
+
```
185
280
186
281
Guidelines:
187
-
1. One bullet per logical change (group related commits)
188
-
2. Project name in bold at the start
189
-
3. One or two sentences describing the change
190
-
4. Change type in italics at the end: *new feature*, *bug fix*, *enhancement*, *refactoring*, etc.
191
-
5. Use @**Name** mentions when authors match channel members
192
-
6. No emojis
282
+
1. One item per logical change (group related commits)
283
+
2. One or two sentences for the description
284
+
3. Use @**Name** mentions in the description when authors match channel members
285
+
4. No emojis
193
286
194
-
Write ONLY the bullet points, no preamble or header.|} commits_text subprojects_text members_text
287
+
Output ONLY the JSON object, no markdown code fences or other text.|} commits_text subprojects_text members_text
195
288
in
196
289
197
290
let response = ask_claude ~sw ~proc ~clock prompt in
198
291
Log.info (fun m -> m "Claude generated: %s" response);
199
-
Some (String.trim response)
292
+
293
+
(* Parse JSON and format with links *)
294
+
match parse_changelog_json (String.trim response) with
295
+
| Ok items ->
296
+
let last_date = most_recent_date commits in
297
+
let header = match last_date with
298
+
| Some d -> Printf.sprintf "**Changes as of %s**\n\n" (date_only d)
299
+
| None -> ""
300
+
in
301
+
let formatted = items
302
+
|> List.map (format_item ~package_urls)
303
+
|> String.concat "\n"
304
+
in
305
+
Some (header ^ formatted)
306
+
| Error _ ->
307
+
(* Fallback: return raw response if JSON parsing fails *)
308
+
Log.warn (fun m -> m "Using raw Claude response as fallback");
309
+
Some (String.trim response)
200
310
end
+12
-6
lib/changelog.mli
+12
-6
lib/changelog.mli
···
16
16
author: string;
17
17
email: string;
18
18
subject: string;
19
+
date: string;
19
20
files: string list;
20
21
}
21
-
(** A git commit with metadata and list of changed files. *)
22
+
(** A git commit with metadata, date, and list of changed files. *)
22
23
23
24
type channel_member = {
24
25
full_name: string;
···
58
59
sw:Eio.Switch.t ->
59
60
proc:_ Eio.Process.mgr ->
60
61
clock:float Eio.Time.clock_ty Eio.Resource.t ->
62
+
fs:_ Eio.Path.t ->
61
63
commits:commit list ->
62
64
members:channel_member list ->
65
+
?opamrepo_path:Fpath.t ->
66
+
unit ->
63
67
string option
64
-
(** [generate ~sw ~proc ~clock ~commits ~members] generates a bullet-point
65
-
changelog using Claude. Returns [None] if commits is empty, or
66
-
[Some changelog] with the generated text.
68
+
(** [generate ~sw ~proc ~clock ~fs ~commits ~members ?opamrepo_path ()] generates
69
+
a bullet-point changelog using Claude. Returns [None] if commits is empty,
70
+
or [Some changelog] with the generated text.
67
71
68
-
Each bullet has the project name in bold, a description of the change,
69
-
and the change type in italics (e.g. "new feature", "bug fix").
72
+
Each bullet has the project name (linked to the actual project repository
73
+
from the opam metadata's dev-repo field if [opamrepo_path] is provided),
74
+
a description of the change, and the change type in italics.
75
+
The output includes a header with the date of the most recent commit.
70
76
Zulip @-mentions are used for authors matching channel members. *)
+5
-2
lib/config.ml
+5
-2
lib/config.ml
···
10
10
monorepo_path : string;
11
11
admin_emails : string list;
12
12
changes_dir : string;
13
+
verse_path : string option; (* Path to verse/ directory containing user monorepos *)
13
14
}
14
15
15
16
let default = {
···
19
20
monorepo_path = ".";
20
21
admin_emails = [];
21
22
changes_dir = ".changes";
23
+
verse_path = None;
22
24
}
23
25
24
26
let codec =
25
27
Tomlt.(
26
28
Table.(
27
-
obj (fun channel topic changes_file monorepo_path admin_emails changes_dir ->
28
-
{ channel; topic; changes_file; monorepo_path; admin_emails; changes_dir })
29
+
obj (fun channel topic changes_file monorepo_path admin_emails changes_dir verse_path ->
30
+
{ channel; topic; changes_file; monorepo_path; admin_emails; changes_dir; verse_path })
29
31
|> mem "channel" string ~dec_absent:default.channel
30
32
~enc:(fun c -> c.channel)
31
33
|> mem "topic" string ~dec_absent:default.topic ~enc:(fun c -> c.topic)
···
37
39
~enc:(fun c -> c.admin_emails)
38
40
|> mem "changes_dir" string ~dec_absent:default.changes_dir
39
41
~enc:(fun c -> c.changes_dir)
42
+
|> opt_mem "verse_path" string ~enc:(fun c -> c.verse_path)
40
43
|> finish))
41
44
42
45
let load_from_path path =
+2
lib/config.mli
+2
lib/config.mli
···
17
17
monorepo_path = "."
18
18
changes_dir = ".changes"
19
19
admin_emails = ["admin@example.com"]
20
+
verse_path = "/path/to/verse"
20
21
v} *)
21
22
22
23
type t = {
···
26
27
monorepo_path : string; (** Path to the monorepo root *)
27
28
admin_emails : string list; (** Emails authorized for admin commands *)
28
29
changes_dir : string; (** Directory for aggregated JSON files *)
30
+
verse_path : string option; (** Path to verse/ directory containing user monorepos *)
29
31
}
30
32
31
33
val default : t
+1
-1
lib/dune
+1
-1
lib/dune
+51
-8
lib/handler.ml
+51
-8
lib/handler.ml
···
88
88
89
89
**Basic Commands:**
90
90
- `help` or `?` - Show this help message
91
-
- `status` - Show bot configuration status
91
+
- `status` - Show bot configuration and tracked verse users with repo links
92
92
- `broadcast` / `post` / `changes` - Generate and broadcast changelog with Claude
93
93
- `refresh` / `pull` / `sync` / `update` - Pull from remote and broadcast changes
94
94
···
106
106
The bot reads its configuration from `poe.toml` with the following fields:
107
107
- `channel` - The Zulip channel to broadcast to
108
108
- `topic` - The topic for broadcast messages
109
-
- `monorepo_path` - Path to the monorepo root
109
+
- `verse_path` - Path to verse/ directory containing user monorepos
110
110
- `admin_emails` - List of emails authorized for admin commands|}
111
111
112
-
let handle_status config =
112
+
(* Load verse registry and get tracked users with their repo URLs *)
113
+
let get_verse_status ~fs ~verse_path =
114
+
let registry_path = Monopam.Verse_config.registry_path () in
115
+
let registry_toml = Fpath.(registry_path / "opamverse.toml") in
116
+
match Monopam.Verse_registry.load ~fs registry_toml with
117
+
| Error msg ->
118
+
Log.warn (fun m -> m "Failed to load registry: %s" msg);
119
+
[]
120
+
| Ok registry ->
121
+
(* Scan verse directory for user subdirectories *)
122
+
let verse_eio = Eio.Path.(fs / verse_path) in
123
+
let subdirs = try
124
+
Eio.Path.read_dir verse_eio
125
+
|> List.filter (fun name ->
126
+
not (String.starts_with ~prefix:"." name) &&
127
+
not (String.ends_with ~suffix:"-opam" name))
128
+
with Eio.Io _ -> []
129
+
in
130
+
(* Match each subdirectory with registry member *)
131
+
List.filter_map (fun handle ->
132
+
match Monopam.Verse_registry.find_member registry ~handle with
133
+
| Some member -> Some (handle, member.monorepo, member.opamrepo)
134
+
| None -> None
135
+
) subdirs
136
+
137
+
let handle_status env config =
113
138
let admin_list = if config.Config.admin_emails = [] then "none configured"
114
139
else String.concat ", " config.Config.admin_emails
115
140
in
141
+
let verse_path = match config.Config.verse_path with
142
+
| Some vp -> vp
143
+
| None ->
144
+
let mono_dir = Filename.dirname config.Config.monorepo_path in
145
+
Filename.concat mono_dir "verse"
146
+
in
147
+
let verse_users = get_verse_status ~fs:env.fs ~verse_path in
148
+
let users_section = if verse_users = [] then
149
+
"- Tracked verse users: none"
150
+
else
151
+
"- Tracked verse users:\n" ^
152
+
(verse_users
153
+
|> List.map (fun (handle, mono_url, opam_url) ->
154
+
Printf.sprintf " - **%s**: [monorepo](%s) | [opam-repo](%s)"
155
+
handle mono_url opam_url)
156
+
|> String.concat "\n")
157
+
in
116
158
Zulip_bot.Response.reply
117
159
(Printf.sprintf
118
160
{|**Poe Bot Status:**
119
161
120
162
- Channel: `%s`
121
163
- Topic: `%s`
122
-
- Monorepo path: `%s`
123
-
- Admin emails: %s|}
164
+
- Verse path: `%s`
165
+
- Admin emails: %s
166
+
%s|}
124
167
config.Config.channel config.Config.topic
125
-
config.Config.monorepo_path admin_list)
168
+
verse_path admin_list users_section)
126
169
127
170
let handle_refresh env ~client ~storage ~config =
128
171
let monorepo_path = Eio.Path.(env.fs / config.Config.monorepo_path) in
···
153
196
let members = Changelog.get_channel_members ~client ~channel:config.Config.channel in
154
197
155
198
(* Generate narrative changelog with Claude *)
156
-
match Changelog.generate ~sw:env.sw ~proc:env.process_mgr ~clock:env.clock ~commits ~members with
199
+
match Changelog.generate ~sw:env.sw ~proc:env.process_mgr ~clock:env.clock ~fs:env.fs ~commits ~members () with
157
200
| None ->
158
201
Zulip_bot.Response.reply
159
202
(Printf.sprintf "**Refresh completed:**\n\n- %s\n- Could not generate changelog" pull_msg)
···
223
266
Log.info (fun m -> m "Received message: %s" content);
224
267
match Commands.parse content with
225
268
| Commands.Help -> handle_help ()
226
-
| Commands.Status -> handle_status config
269
+
| Commands.Status -> handle_status env config
227
270
| Commands.Broadcast ->
228
271
Broadcast.run ~sw:env.sw ~proc:env.process_mgr ~clock:env.clock
229
272
~fs:env.fs ~client ~storage ~config
+210
-89
lib/loop.ml
+210
-89
lib/loop.ml
···
6
6
let src = Logs.Src.create "poe.loop" ~doc:"Poe polling loop"
7
7
module Log = (val Logs.src_log src : Logs.LOG)
8
8
9
-
let get_git_head ~proc ~cwd =
10
-
Eio.Switch.run @@ fun sw ->
11
-
let buf = Buffer.create 64 in
12
-
let child = Eio.Process.spawn proc ~sw ~cwd
13
-
~stdout:(Eio.Flow.buffer_sink buf)
14
-
["git"; "rev-parse"; "--short"; "HEAD"]
15
-
in
16
-
match Eio.Process.await child with
17
-
| `Exited 0 -> Some (String.trim (Buffer.contents buf))
18
-
| _ -> None
9
+
(* Verse user info for iteration *)
10
+
type verse_user = {
11
+
handle : string;
12
+
monorepo_path : Eio.Fs.dir_ty Eio.Path.t;
13
+
monorepo_url : string;
14
+
opamrepo_url : string;
15
+
opamrepo_path : Fpath.t option; (* Local path to opam repo for reading dev-repo URLs *)
16
+
}
19
17
20
-
let run_git_pull ~proc ~cwd =
21
-
Log.info (fun m -> m "Pulling latest changes from remote");
18
+
(* Load the opamverse registry from XDG data path *)
19
+
let load_registry ~fs =
20
+
let registry_path = Monopam.Verse_config.registry_path () in
21
+
let registry_toml = Fpath.(registry_path / "opamverse.toml") in
22
+
Monopam.Verse_registry.load ~fs registry_toml
23
+
24
+
(* Get list of verse users by scanning verse directory and matching with registry *)
25
+
let get_verse_users ~fs ~verse_path =
26
+
match load_registry ~fs with
27
+
| Error msg ->
28
+
Log.warn (fun m -> m "Failed to load registry: %s" msg);
29
+
[]
30
+
| Ok registry ->
31
+
(* Scan verse directory for user subdirectories *)
32
+
let verse_eio = Eio.Path.(fs / verse_path) in
33
+
let subdirs = try
34
+
Eio.Path.read_dir verse_eio
35
+
|> List.filter (fun name ->
36
+
(* Filter out -opam directories and hidden files *)
37
+
not (String.starts_with ~prefix:"." name) &&
38
+
not (String.ends_with ~suffix:"-opam" name))
39
+
with Eio.Io _ ->
40
+
Log.warn (fun m -> m "Failed to read verse directory: %s" verse_path);
41
+
[]
42
+
in
43
+
(* Match each subdirectory with registry member *)
44
+
List.filter_map (fun handle ->
45
+
match Monopam.Verse_registry.find_member registry ~handle with
46
+
| Some member ->
47
+
let mono_path = Eio.Path.(verse_eio / handle) in
48
+
(* Check if it's actually a git repo *)
49
+
let is_repo = try
50
+
match Eio.Path.kind ~follow:true Eio.Path.(mono_path / ".git") with
51
+
| `Directory -> true
52
+
| _ -> false
53
+
with _ -> false
54
+
in
55
+
if is_repo then
56
+
(* Check if local opam repo exists *)
57
+
let opam_dir = handle ^ "-opam" in
58
+
let opam_path = Eio.Path.(verse_eio / opam_dir) in
59
+
let opamrepo_path = try
60
+
match Eio.Path.kind ~follow:true opam_path with
61
+
| `Directory -> Some (Fpath.v (verse_path ^ "/" ^ opam_dir))
62
+
| _ -> None
63
+
with _ -> None
64
+
in
65
+
Some {
66
+
handle;
67
+
monorepo_path = mono_path;
68
+
monorepo_url = member.monorepo;
69
+
opamrepo_url = member.opamrepo;
70
+
opamrepo_path;
71
+
}
72
+
else begin
73
+
Log.debug (fun m -> m "Skipping %s: not a git repo" handle);
74
+
None
75
+
end
76
+
| None ->
77
+
Log.debug (fun m -> m "Skipping %s: not in registry" handle);
78
+
None
79
+
) subdirs
80
+
81
+
let run_command ~proc ~cwd cmd =
82
+
let cwd_str = Eio.Path.native_exn cwd in
83
+
Log.debug (fun m -> m "Running: %s (in %s)" (String.concat " " cmd) cwd_str);
22
84
Eio.Switch.run @@ fun sw ->
23
85
let buf_stdout = Buffer.create 256 in
24
86
let buf_stderr = Buffer.create 256 in
25
87
let child = Eio.Process.spawn proc ~sw ~cwd
26
88
~stdout:(Eio.Flow.buffer_sink buf_stdout)
27
89
~stderr:(Eio.Flow.buffer_sink buf_stderr)
28
-
["git"; "pull"; "--ff-only"]
90
+
cmd
29
91
in
30
-
match Eio.Process.await child with
31
-
| `Exited 0 ->
32
-
let output = String.trim (Buffer.contents buf_stdout) in
33
-
if output = "Already up to date." then
34
-
Log.info (fun m -> m "Repository already up to date")
35
-
else begin
36
-
Log.info (fun m -> m "Pulled new changes from remote");
37
-
String.split_on_char '\n' output
38
-
|> List.iter (fun line ->
39
-
let line = String.trim line in
40
-
if line <> "" then Log.info (fun m -> m " %s" line))
41
-
end;
42
-
true
43
-
| `Exited code ->
44
-
let stderr = String.trim (Buffer.contents buf_stderr) in
45
-
Log.warn (fun m -> m "git pull exited with code %d: %s" code stderr);
46
-
false
47
-
| `Signaled sig_ ->
48
-
Log.warn (fun m -> m "git pull killed by signal %d" sig_);
92
+
(* Must await process before reading buffers *)
93
+
let status = Eio.Process.await child in
94
+
let stdout = Buffer.contents buf_stdout in
95
+
let stderr = Buffer.contents buf_stderr in
96
+
match status with
97
+
| `Exited code -> (code, stdout, stderr)
98
+
| `Signaled sig_ -> (-sig_, stdout, stderr)
99
+
100
+
let get_git_head ~proc ~cwd =
101
+
match run_command ~proc ~cwd ["git"; "rev-parse"; "--short"; "HEAD"] with
102
+
| (0, stdout, _) -> Some (String.trim stdout)
103
+
| _ -> None
104
+
105
+
(* Sync a tracked repo by fetching and resetting to upstream.
106
+
We don't make local commits to verse repos, so reset is safe. *)
107
+
let sync_to_upstream ~proc ~cwd ~handle =
108
+
Log.debug (fun m -> m "[%s] Fetching from origin" handle);
109
+
match run_command ~proc ~cwd ["git"; "fetch"; "origin"] with
110
+
| (0, _, _) ->
111
+
(* Get the default branch name *)
112
+
let branch = match run_command ~proc ~cwd
113
+
["git"; "rev-parse"; "--abbrev-ref"; "origin/HEAD"] with
114
+
| (0, stdout, _) ->
115
+
(* Returns "origin/main" or "origin/master" - extract branch name *)
116
+
let full = String.trim stdout in
117
+
(match String.split_on_char '/' full with
118
+
| _ :: branch :: _ -> branch
119
+
| _ -> "main")
120
+
| _ -> "main"
121
+
in
122
+
Log.debug (fun m -> m "[%s] Resetting to origin/%s" handle branch);
123
+
(match run_command ~proc ~cwd ["git"; "reset"; "--hard"; "origin/" ^ branch] with
124
+
| (0, _, _) -> true
125
+
| (code, _, stderr) ->
126
+
Log.warn (fun m -> m "[%s] git reset failed (code %d): %s"
127
+
handle code (String.trim stderr));
128
+
false)
129
+
| (code, _, stderr) ->
130
+
Log.warn (fun m -> m "[%s] git fetch failed (code %d): %s"
131
+
handle code (String.trim stderr));
49
132
false
50
133
51
134
let send_message ~client ~stream ~topic ~content =
···
53
136
let resp = Zulip.Messages.send client msg in
54
137
Log.info (fun m -> m "Broadcast sent, message ID: %d" (Zulip.Message_response.id resp))
55
138
139
+
(* Process a single verse user: pull, check HEAD, generate changelog if needed *)
140
+
let process_verse_user ~sw ~proc ~clock ~fs ~storage ~client ~config user =
141
+
let handle = user.handle in
142
+
Log.info (fun m -> m "Checking %s for changes..." handle);
143
+
144
+
(* Sync to upstream (fetch + reset, since we don't make local commits here) *)
145
+
let _sync_ok = sync_to_upstream ~proc ~cwd:user.monorepo_path ~handle in
146
+
147
+
(* Get current git HEAD *)
148
+
let current_head = get_git_head ~proc ~cwd:user.monorepo_path in
149
+
let last_head = Admin.get_user_git_head storage ~handle in
150
+
151
+
Log.info (fun m -> m "[%s] Current HEAD: %s, Last HEAD: %s" handle
152
+
(Option.value ~default:"(none)" current_head)
153
+
(Option.value ~default:"(none)" last_head));
154
+
155
+
(* Check if HEAD has changed *)
156
+
let head_changed = match (current_head, last_head) with
157
+
| (Some c, Some l) -> c <> l
158
+
| (Some _, None) -> true (* First run for this user *)
159
+
| _ -> false
160
+
in
161
+
162
+
if head_changed then begin
163
+
Log.info (fun m -> m "[%s] Git HEAD changed, generating changes..." handle);
164
+
165
+
(* Get commits since last HEAD, or last 25 on first run *)
166
+
let commits = match last_head with
167
+
| Some h -> Changelog.get_git_log ~proc ~cwd:user.monorepo_path ~since_head:h
168
+
| None -> Changelog.get_recent_commits ~proc ~cwd:user.monorepo_path ~count:25
169
+
in
170
+
171
+
if commits = [] then begin
172
+
Log.info (fun m -> m "[%s] No commits to broadcast" handle);
173
+
(* Still update HEAD so we don't reprocess *)
174
+
Option.iter (Admin.set_user_git_head storage ~handle) current_head
175
+
end
176
+
else begin
177
+
(* Get channel members for @mentions *)
178
+
let members = Changelog.get_channel_members ~client ~channel:config.Config.channel in
179
+
180
+
(* Generate narrative changelog with Claude *)
181
+
match Changelog.generate ~sw ~proc ~clock ~fs ~commits ~members
182
+
?opamrepo_path:user.opamrepo_path () with
183
+
| None ->
184
+
Log.info (fun m -> m "[%s] No changelog generated" handle);
185
+
Option.iter (Admin.set_user_git_head storage ~handle) current_head
186
+
| Some changelog_content ->
187
+
Log.info (fun m -> m "[%s] Broadcasting narrative changelog" handle);
188
+
189
+
(* Format the broadcast with repo hrefs *)
190
+
let content = Printf.sprintf
191
+
{|**Updates from %s**
192
+
193
+
Repos: [monorepo](%s) | [opam-repo](%s)
194
+
195
+
%s|}
196
+
handle user.monorepo_url user.opamrepo_url changelog_content
197
+
in
198
+
199
+
send_message ~client ~stream:config.Config.channel
200
+
~topic:config.Config.topic ~content;
201
+
202
+
(* Update storage with per-user HEAD *)
203
+
let now = Ptime_clock.now () in
204
+
Admin.set_last_broadcast_time storage now;
205
+
Option.iter (Admin.set_user_git_head storage ~handle) current_head;
206
+
Log.info (fun m -> m "[%s] Updated broadcast time and git HEAD" handle)
207
+
end
208
+
end
209
+
else
210
+
Log.debug (fun m -> m "[%s] No HEAD change, skipping" handle)
211
+
56
212
let run ~sw ~env ~config ~zulip_config ~handler ~interval =
57
213
let fs = Eio.Stdenv.fs env in
58
214
let proc = Eio.Stdenv.process_mgr env in
···
62
218
let client = Zulip_bot.Bot.create_client ~sw ~env ~config:zulip_config in
63
219
let storage = Zulip_bot.Storage.create client in
64
220
65
-
let monorepo_path = Eio.Path.(fs / config.Config.monorepo_path) in
221
+
Log.info (fun m -> m "Starting loop with %d second interval" interval);
66
222
67
-
Log.info (fun m -> m "Starting loop with %d second interval" interval);
223
+
(* Determine verse path - use config.verse_path if set, otherwise derive from monorepo_path *)
224
+
let verse_path = match config.Config.verse_path with
225
+
| Some vp -> vp
226
+
| None ->
227
+
(* Assume verse/ is a sibling of monorepo_path's parent *)
228
+
let mono_dir = Filename.dirname config.Config.monorepo_path in
229
+
Filename.concat mono_dir "verse"
230
+
in
231
+
Log.info (fun m -> m "Verse path: %s" verse_path);
68
232
69
233
let broadcast_loop () =
70
234
let rec loop () =
71
-
Log.info (fun m -> m "Checking for changes...");
72
-
73
-
(* Pull latest changes from remote *)
74
-
let _pull_ok = run_git_pull ~proc ~cwd:monorepo_path in
75
-
76
-
(* Get current git HEAD *)
77
-
let current_head = get_git_head ~proc ~cwd:monorepo_path in
78
-
let last_head = Admin.get_last_git_head storage in
79
-
80
-
Log.info (fun m -> m "Current HEAD: %s, Last HEAD: %s"
81
-
(Option.value ~default:"(none)" current_head)
82
-
(Option.value ~default:"(none)" last_head));
83
-
84
-
(* Check if HEAD has changed *)
85
-
let head_changed = match (current_head, last_head) with
86
-
| (Some c, Some l) -> c <> l
87
-
| (Some _, None) -> true (* First run *)
88
-
| _ -> false
89
-
in
90
-
91
-
if head_changed then begin
92
-
Log.info (fun m -> m "Git HEAD changed, generating changes...");
93
-
94
-
(* Get commits since last HEAD *)
95
-
let commits = match last_head with
96
-
| Some h -> Changelog.get_git_log ~proc ~cwd:monorepo_path ~since_head:h
97
-
| None -> [] (* First run, don't broadcast everything *)
98
-
in
99
-
100
-
if commits = [] then begin
101
-
Log.info (fun m -> m "No commits to broadcast");
102
-
(* Still update HEAD so we don't reprocess *)
103
-
Option.iter (Admin.set_last_git_head storage) current_head
104
-
end
105
-
else begin
106
-
(* Get channel members for @mentions *)
107
-
let members = Changelog.get_channel_members ~client ~channel:config.Config.channel in
235
+
Log.info (fun m -> m "Checking for changes across verse users...");
108
236
109
-
(* Generate narrative changelog with Claude *)
110
-
match Changelog.generate ~sw ~proc ~clock ~commits ~members with
111
-
| None ->
112
-
Log.info (fun m -> m "No changelog generated");
113
-
Option.iter (Admin.set_last_git_head storage) current_head
114
-
| Some content ->
115
-
Log.info (fun m -> m "Broadcasting narrative changelog");
116
-
send_message ~client ~stream:config.Config.channel
117
-
~topic:config.Config.topic ~content;
237
+
(* Get all verse users *)
238
+
let users = get_verse_users ~fs ~verse_path in
239
+
Log.info (fun m -> m "Found %d verse users" (List.length users));
118
240
119
-
(* Update storage *)
120
-
let now = Ptime_clock.now () in
121
-
Admin.set_last_broadcast_time storage now;
122
-
Option.iter (Admin.set_last_git_head storage) current_head;
123
-
Log.info (fun m -> m "Updated broadcast time and git HEAD")
124
-
end
125
-
end
126
-
else
127
-
Log.debug (fun m -> m "No HEAD change, skipping");
241
+
(* Process each user *)
242
+
List.iter (fun user ->
243
+
try
244
+
process_verse_user ~sw ~proc ~clock ~fs ~storage ~client ~config user
245
+
with e ->
246
+
Log.warn (fun m -> m "[%s] Error processing user: %s"
247
+
user.handle (Printexc.to_string e))
248
+
) users;
128
249
129
250
(* Sleep until next check *)
130
251
Log.info (fun m -> m "Sleeping for %d seconds" interval);