My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1let src = Logs.Src.create "claude.hooks" ~doc:"Claude hooks system"
2module Log = (val Logs.src_log src : Logs.LOG)
3
4(** Hook events that can be intercepted *)
5type event =
6 | Pre_tool_use
7 | Post_tool_use
8 | User_prompt_submit
9 | Stop
10 | Subagent_stop
11 | Pre_compact
12
13let event_to_string = function
14 | Pre_tool_use -> "PreToolUse"
15 | Post_tool_use -> "PostToolUse"
16 | User_prompt_submit -> "UserPromptSubmit"
17 | Stop -> "Stop"
18 | Subagent_stop -> "SubagentStop"
19 | Pre_compact -> "PreCompact"
20
21let event_of_string = function
22 | "PreToolUse" -> Pre_tool_use
23 | "PostToolUse" -> Post_tool_use
24 | "UserPromptSubmit" -> User_prompt_submit
25 | "Stop" -> Stop
26 | "SubagentStop" -> Subagent_stop
27 | "PreCompact" -> Pre_compact
28 | s -> raise (Invalid_argument (Printf.sprintf "Unknown hook event: %s" s))
29
30let event_jsont : event Jsont.t =
31 Jsont.enum [
32 "PreToolUse", Pre_tool_use;
33 "PostToolUse", Post_tool_use;
34 "UserPromptSubmit", User_prompt_submit;
35 "Stop", Stop;
36 "SubagentStop", Subagent_stop;
37 "PreCompact", Pre_compact;
38 ]
39
40(** Context provided to hook callbacks *)
41module Context = struct
42 type t = {
43 signal: unit option; (* Future: abort signal support *)
44 unknown : Unknown.t;
45 }
46
47 let create ?(signal = None) ?(unknown = Unknown.empty) () = { signal; unknown }
48
49 let signal t = t.signal
50 let unknown t = t.unknown
51
52 let jsont : t Jsont.t =
53 let make unknown = { signal = None; unknown } in
54 Jsont.Object.map ~kind:"Context" make
55 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
56 |> Jsont.Object.finish
57end
58
59(** Hook decision control *)
60type decision =
61 | Continue
62 | Block
63
64let decision_jsont : decision Jsont.t =
65 Jsont.enum [
66 "continue", Continue;
67 "block", Block;
68 ]
69
70(** Generic hook result *)
71type result = {
72 decision: decision option;
73 system_message: string option;
74 hook_specific_output: Jsont.json option;
75 unknown : Unknown.t;
76}
77
78let result_jsont : result Jsont.t =
79 let make decision system_message hook_specific_output unknown =
80 { decision; system_message; hook_specific_output; unknown }
81 in
82 Jsont.Object.map ~kind:"Result" make
83 |> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun r -> r.decision)
84 |> Jsont.Object.opt_mem "systemMessage" Jsont.string ~enc:(fun r -> r.system_message)
85 |> Jsont.Object.opt_mem "hookSpecificOutput" Jsont.json ~enc:(fun r -> r.hook_specific_output)
86 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
87 |> Jsont.Object.finish
88
89(** {1 PreToolUse Hook} *)
90module PreToolUse = struct
91 type input = {
92 session_id: string;
93 transcript_path: string;
94 tool_name: string;
95 tool_input: Jsont.json;
96 unknown : Unknown.t;
97 }
98
99 type t = input
100
101 let session_id t = t.session_id
102 let transcript_path t = t.transcript_path
103 let tool_name t = t.tool_name
104 let tool_input t = t.tool_input
105 let unknown t = t.unknown
106
107 let input_jsont : input Jsont.t =
108 let make session_id transcript_path tool_name tool_input unknown =
109 { session_id; transcript_path; tool_name; tool_input; unknown }
110 in
111 Jsont.Object.map ~kind:"PreToolUseInput" make
112 |> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
113 |> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
114 |> Jsont.Object.mem "tool_name" Jsont.string ~enc:tool_name
115 |> Jsont.Object.mem "tool_input" Jsont.json ~enc:tool_input
116 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
117 |> Jsont.Object.finish
118
119 let of_json json =
120 match Jsont.Json.decode input_jsont json with
121 | Ok v -> v
122 | Error msg -> raise (Invalid_argument ("PreToolUse: " ^ msg))
123
124 type permission_decision = [ `Allow | `Deny | `Ask ]
125
126 let permission_decision_jsont : permission_decision Jsont.t =
127 Jsont.enum [
128 "allow", `Allow;
129 "deny", `Deny;
130 "ask", `Ask;
131 ]
132
133 type output = {
134 permission_decision: permission_decision option;
135 permission_decision_reason: string option;
136 updated_input: Jsont.json option;
137 unknown : Unknown.t;
138 }
139
140 let output_jsont : output Jsont.t =
141 let make permission_decision permission_decision_reason updated_input unknown =
142 { permission_decision; permission_decision_reason; updated_input; unknown }
143 in
144 Jsont.Object.map ~kind:"PreToolUseOutput" make
145 |> Jsont.Object.opt_mem "permissionDecision" permission_decision_jsont ~enc:(fun o -> o.permission_decision)
146 |> Jsont.Object.opt_mem "permissionDecisionReason" Jsont.string ~enc:(fun o -> o.permission_decision_reason)
147 |> Jsont.Object.opt_mem "updatedInput" Jsont.json ~enc:(fun o -> o.updated_input)
148 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun o -> o.unknown)
149 |> Jsont.Object.finish
150
151 let output_to_json output =
152 match Jsont.Json.encode output_jsont output with
153 | Ok json -> json
154 | Error msg -> failwith ("PreToolUse.output_to_json: " ^ msg)
155
156 let allow ?reason ?updated_input ?(unknown = Unknown.empty) () =
157 { permission_decision = Some `Allow; permission_decision_reason = reason;
158 updated_input; unknown }
159
160 let deny ?reason ?(unknown = Unknown.empty) () =
161 { permission_decision = Some `Deny; permission_decision_reason = reason;
162 updated_input = None; unknown }
163
164 let ask ?reason ?(unknown = Unknown.empty) () =
165 { permission_decision = Some `Ask; permission_decision_reason = reason;
166 updated_input = None; unknown }
167
168 let continue ?(unknown = Unknown.empty) () =
169 { permission_decision = None; permission_decision_reason = None;
170 updated_input = None; unknown }
171end
172
173(** {1 PostToolUse Hook} *)
174module PostToolUse = struct
175 type input = {
176 session_id: string;
177 transcript_path: string;
178 tool_name: string;
179 tool_input: Jsont.json;
180 tool_response: Jsont.json;
181 unknown : Unknown.t;
182 }
183
184 type t = input
185
186 let session_id t = t.session_id
187 let transcript_path t = t.transcript_path
188 let tool_name t = t.tool_name
189 let tool_input t = t.tool_input
190 let tool_response t = t.tool_response
191 let unknown t = t.unknown
192
193 let input_jsont : input Jsont.t =
194 let make session_id transcript_path tool_name tool_input tool_response unknown =
195 { session_id; transcript_path; tool_name; tool_input; tool_response; unknown }
196 in
197 Jsont.Object.map ~kind:"PostToolUseInput" make
198 |> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
199 |> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
200 |> Jsont.Object.mem "tool_name" Jsont.string ~enc:tool_name
201 |> Jsont.Object.mem "tool_input" Jsont.json ~enc:tool_input
202 |> Jsont.Object.mem "tool_response" Jsont.json ~enc:tool_response
203 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
204 |> Jsont.Object.finish
205
206 let of_json json =
207 match Jsont.Json.decode input_jsont json with
208 | Ok v -> v
209 | Error msg -> raise (Invalid_argument ("PostToolUse: " ^ msg))
210
211 type output = {
212 decision: decision option;
213 reason: string option;
214 additional_context: string option;
215 unknown : Unknown.t;
216 }
217
218 let output_jsont : output Jsont.t =
219 let make decision reason additional_context unknown =
220 { decision; reason; additional_context; unknown }
221 in
222 Jsont.Object.map ~kind:"PostToolUseOutput" make
223 |> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o -> o.decision)
224 |> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
225 |> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o -> o.additional_context)
226 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun o -> o.unknown)
227 |> Jsont.Object.finish
228
229 let output_to_json output =
230 match Jsont.Json.encode output_jsont output with
231 | Ok json -> json
232 | Error msg -> failwith ("PostToolUse.output_to_json: " ^ msg)
233
234 let continue ?additional_context ?(unknown = Unknown.empty) () =
235 { decision = None; reason = None; additional_context; unknown }
236
237 let block ?reason ?additional_context ?(unknown = Unknown.empty) () =
238 { decision = Some Block; reason; additional_context; unknown }
239end
240
241(** {1 UserPromptSubmit Hook} *)
242module UserPromptSubmit = struct
243 type input = {
244 session_id: string;
245 transcript_path: string;
246 prompt: string;
247 unknown : Unknown.t;
248 }
249
250 type t = input
251
252 let session_id t = t.session_id
253 let transcript_path t = t.transcript_path
254 let prompt t = t.prompt
255 let unknown t = t.unknown
256
257 let input_jsont : input Jsont.t =
258 let make session_id transcript_path prompt unknown =
259 { session_id; transcript_path; prompt; unknown }
260 in
261 Jsont.Object.map ~kind:"UserPromptSubmitInput" make
262 |> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
263 |> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
264 |> Jsont.Object.mem "prompt" Jsont.string ~enc:prompt
265 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
266 |> Jsont.Object.finish
267
268 let of_json json =
269 match Jsont.Json.decode input_jsont json with
270 | Ok v -> v
271 | Error msg -> raise (Invalid_argument ("UserPromptSubmit: " ^ msg))
272
273 type output = {
274 decision: decision option;
275 reason: string option;
276 additional_context: string option;
277 unknown : Unknown.t;
278 }
279
280 let output_jsont : output Jsont.t =
281 let make decision reason additional_context unknown =
282 { decision; reason; additional_context; unknown }
283 in
284 Jsont.Object.map ~kind:"UserPromptSubmitOutput" make
285 |> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o -> o.decision)
286 |> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
287 |> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o -> o.additional_context)
288 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun o -> o.unknown)
289 |> Jsont.Object.finish
290
291 let output_to_json output =
292 match Jsont.Json.encode output_jsont output with
293 | Ok json -> json
294 | Error msg -> failwith ("UserPromptSubmit.output_to_json: " ^ msg)
295
296 let continue ?additional_context ?(unknown = Unknown.empty) () =
297 { decision = None; reason = None; additional_context; unknown }
298
299 let block ?reason ?(unknown = Unknown.empty) () =
300 { decision = Some Block; reason; additional_context = None; unknown }
301end
302
303(** {1 Stop Hook} *)
304module Stop = struct
305 type input = {
306 session_id: string;
307 transcript_path: string;
308 stop_hook_active: bool;
309 unknown : Unknown.t;
310 }
311
312 type t = input
313
314 let session_id t = t.session_id
315 let transcript_path t = t.transcript_path
316 let stop_hook_active t = t.stop_hook_active
317 let unknown t = t.unknown
318
319 let input_jsont : input Jsont.t =
320 let make session_id transcript_path stop_hook_active unknown =
321 { session_id; transcript_path; stop_hook_active; unknown }
322 in
323 Jsont.Object.map ~kind:"StopInput" make
324 |> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
325 |> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
326 |> Jsont.Object.mem "stop_hook_active" Jsont.bool ~enc:stop_hook_active
327 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
328 |> Jsont.Object.finish
329
330 let of_json json =
331 match Jsont.Json.decode input_jsont json with
332 | Ok v -> v
333 | Error msg -> raise (Invalid_argument ("Stop: " ^ msg))
334
335 type output = {
336 decision: decision option;
337 reason: string option;
338 unknown : Unknown.t;
339 }
340
341 let output_jsont : output Jsont.t =
342 let make decision reason unknown =
343 { decision; reason; unknown }
344 in
345 Jsont.Object.map ~kind:"StopOutput" make
346 |> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o -> o.decision)
347 |> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
348 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun o -> o.unknown)
349 |> Jsont.Object.finish
350
351 let output_to_json output =
352 match Jsont.Json.encode output_jsont output with
353 | Ok json -> json
354 | Error msg -> failwith ("Stop.output_to_json: " ^ msg)
355
356 let continue ?(unknown = Unknown.empty) () = { decision = None; reason = None; unknown }
357 let block ?reason ?(unknown = Unknown.empty) () = { decision = Some Block; reason; unknown }
358end
359
360(** {1 SubagentStop Hook} - Same structure as Stop *)
361module SubagentStop = struct
362 include Stop
363end
364
365(** {1 PreCompact Hook} *)
366module PreCompact = struct
367 type input = {
368 session_id: string;
369 transcript_path: string;
370 unknown : Unknown.t;
371 }
372
373 type t = input
374
375 let session_id t = t.session_id
376 let transcript_path t = t.transcript_path
377 let unknown t = t.unknown
378
379 let input_jsont : input Jsont.t =
380 let make session_id transcript_path unknown =
381 { session_id; transcript_path; unknown }
382 in
383 Jsont.Object.map ~kind:"PreCompactInput" make
384 |> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
385 |> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
386 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
387 |> Jsont.Object.finish
388
389 let of_json json =
390 match Jsont.Json.decode input_jsont json with
391 | Ok v -> v
392 | Error msg -> raise (Invalid_argument ("PreCompact: " ^ msg))
393
394 type output = unit (* No specific output for PreCompact *)
395
396 let output_to_json () = Jsont.Object ([], Jsont.Meta.none)
397
398 let continue () = ()
399end
400
401(** {1 Generic Callback Type} *)
402type callback =
403 input:Jsont.json ->
404 tool_use_id:string option ->
405 context:Context.t ->
406 result
407
408(** {1 Matcher Configuration} *)
409type matcher = {
410 matcher: string option;
411 callbacks: callback list;
412}
413
414type config = (event * matcher list) list
415
416(** {1 Result Builders} *)
417let continue ?system_message ?hook_specific_output ?(unknown = Unknown.empty) () =
418 { decision = None; system_message; hook_specific_output; unknown }
419
420let block ?system_message ?hook_specific_output ?(unknown = Unknown.empty) () =
421 { decision = Some Block; system_message; hook_specific_output; unknown }
422
423(** {1 Matcher Builders} *)
424let matcher ?pattern callbacks = { matcher = pattern; callbacks }
425
426(** {1 Config Builders} *)
427let empty = []
428
429let add event matchers config =
430 (event, matchers) :: config
431
432(** {1 JSON Conversion} *)
433let result_to_json result =
434 match Jsont.Json.encode result_jsont result with
435 | Ok json -> json
436 | Error msg -> failwith ("result_to_json: " ^ msg)
437
438let config_to_protocol_format config =
439 let hooks_dict = List.map (fun (event, matchers) ->
440 let event_name = event_to_string event in
441 let matchers_json = List.map (fun m ->
442 (* matcher and hookCallbackIds will be filled in by client *)
443 let mems = [
444 Jsont.Json.mem (Jsont.Json.name "matcher") (match m.matcher with
445 | Some p -> Jsont.Json.string p
446 | None -> Jsont.Json.null ());
447 Jsont.Json.mem (Jsont.Json.name "callbacks") (Jsont.Json.list []); (* Placeholder, filled by client *)
448 ] in
449 Jsont.Json.object' mems
450 ) matchers in
451 Jsont.Json.mem (Jsont.Json.name event_name) (Jsont.Json.list matchers_json)
452 ) config in
453 Jsont.Json.object' hooks_dict