My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1let src = Logs.Src.create "claude.sdk_control" ~doc:"Claude SDK control protocol"
2module Log = (val Logs.src_log src : Logs.LOG)
3
4(** MCP Message Routing *)
5module Mcp_message = struct
6 module Unknown = struct
7 type t = Jsont.json
8 let empty = Jsont.Object ([], Jsont.Meta.none)
9 let is_empty = function Jsont.Object ([], _) -> true | _ -> false
10 let jsont = Jsont.json
11 end
12
13 type request = {
14 server_name : string;
15 message : Jsont.json;
16 unknown : Unknown.t;
17 }
18
19 type response = {
20 mcp_response : Jsont.json;
21 unknown : Unknown.t;
22 }
23
24 let make_request ~server_name ~message ?(unknown = Unknown.empty) () =
25 { server_name; message; unknown }
26
27 let make_response ~mcp_response ?(unknown = Unknown.empty) () =
28 { mcp_response; unknown }
29
30 let request_jsont : request Jsont.t =
31 let make server_name message (unknown : Unknown.t) : request =
32 { server_name; message; unknown }
33 in
34 Jsont.Object.map ~kind:"McpMessageRequest" make
35 |> Jsont.Object.mem "server_name" Jsont.string ~enc:(fun (r : request) -> r.server_name)
36 |> Jsont.Object.mem "message" Jsont.json ~enc:(fun (r : request) -> r.message)
37 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : request) -> r.unknown)
38 |> Jsont.Object.finish
39
40 let response_jsont : response Jsont.t =
41 let make mcp_response (unknown : Unknown.t) : response =
42 { mcp_response; unknown }
43 in
44 Jsont.Object.map ~kind:"McpMessageResponse" make
45 |> Jsont.Object.mem "mcp_response" Jsont.json ~enc:(fun (r : response) -> r.mcp_response)
46 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : response) -> r.unknown)
47 |> Jsont.Object.finish
48
49 let pp_request fmt req =
50 Fmt.pf fmt "@[<2>McpMessage.Request@ { server = %S }@]" req.server_name
51
52 let pp_response fmt _resp =
53 Fmt.pf fmt "@[<2>McpMessage.Response@ { mcp_response = <json> }@]"
54end
55
56module Request = struct
57 type interrupt = {
58 subtype : [`Interrupt];
59 unknown : Unknown.t;
60 }
61
62 type permission = {
63 subtype : [`Can_use_tool];
64 tool_name : string;
65 input : Jsont.json;
66 permission_suggestions : Permissions.Update.t list option;
67 blocked_path : string option;
68 unknown : Unknown.t;
69 }
70
71 type initialize = {
72 subtype : [`Initialize];
73 hooks : (string * Jsont.json) list option;
74 unknown : Unknown.t;
75 }
76
77 type set_permission_mode = {
78 subtype : [`Set_permission_mode];
79 mode : Permissions.Mode.t;
80 unknown : Unknown.t;
81 }
82
83 type hook_callback = {
84 subtype : [`Hook_callback];
85 callback_id : string;
86 input : Jsont.json;
87 tool_use_id : string option;
88 unknown : Unknown.t;
89 }
90
91 type set_model = {
92 subtype : [`Set_model];
93 model : string;
94 unknown : Unknown.t;
95 }
96
97 type get_server_info = {
98 subtype : [`Get_server_info];
99 unknown : Unknown.t;
100 }
101
102 type t =
103 | Interrupt of interrupt
104 | Permission of permission
105 | Initialize of initialize
106 | Set_permission_mode of set_permission_mode
107 | Hook_callback of hook_callback
108 | Mcp_message of Mcp_message.request
109 | Set_model of set_model
110 | Get_server_info of get_server_info
111
112 let interrupt ?(unknown = Unknown.empty) () =
113 Interrupt { subtype = `Interrupt; unknown }
114
115 let permission ~tool_name ~input ?permission_suggestions ?blocked_path ?(unknown = Unknown.empty) () =
116 Permission {
117 subtype = `Can_use_tool;
118 tool_name;
119 input;
120 permission_suggestions;
121 blocked_path;
122 unknown;
123 }
124
125 let initialize ?hooks ?(unknown = Unknown.empty) () =
126 Initialize { subtype = `Initialize; hooks; unknown }
127
128 let set_permission_mode ~mode ?(unknown = Unknown.empty) () =
129 Set_permission_mode { subtype = `Set_permission_mode; mode; unknown }
130
131 let hook_callback ~callback_id ~input ?tool_use_id ?(unknown = Unknown.empty) () =
132 Hook_callback {
133 subtype = `Hook_callback;
134 callback_id;
135 input;
136 tool_use_id;
137 unknown;
138 }
139
140 let mcp_message ~server_name ~message ?(unknown = Unknown.empty) () =
141 Mcp_message (Mcp_message.make_request ~server_name ~message ~unknown ())
142
143 let set_model ~model ?(unknown = Unknown.empty) () =
144 Set_model { subtype = `Set_model; model; unknown }
145
146 let get_server_info ?(unknown = Unknown.empty) () =
147 Get_server_info { subtype = `Get_server_info; unknown }
148
149 (* Individual record codecs *)
150 let interrupt_jsont : interrupt Jsont.t =
151 let make (unknown : Unknown.t) : interrupt = { subtype = `Interrupt; unknown } in
152 Jsont.Object.map ~kind:"Interrupt" make
153 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : interrupt) -> r.unknown)
154 |> Jsont.Object.finish
155
156 let permission_jsont : permission Jsont.t =
157 let make tool_name input permission_suggestions blocked_path (unknown : Unknown.t) : permission =
158 { subtype = `Can_use_tool; tool_name; input; permission_suggestions; blocked_path; unknown }
159 in
160 Jsont.Object.map ~kind:"Permission" make
161 |> Jsont.Object.mem "tool_name" Jsont.string ~enc:(fun (r : permission) -> r.tool_name)
162 |> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : permission) -> r.input)
163 |> Jsont.Object.opt_mem "permission_suggestions" (Jsont.list Permissions.Update.jsont) ~enc:(fun (r : permission) -> r.permission_suggestions)
164 |> Jsont.Object.opt_mem "blocked_path" Jsont.string ~enc:(fun (r : permission) -> r.blocked_path)
165 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : permission) -> r.unknown)
166 |> Jsont.Object.finish
167
168 let initialize_jsont : initialize Jsont.t =
169 (* The hooks field is an object with string keys and json values *)
170 let hooks_map_jsont = Jsont.Object.as_string_map Jsont.json in
171 let module StringMap = Map.Make(String) in
172 let hooks_jsont = Jsont.map
173 ~dec:(fun m -> StringMap.bindings m)
174 ~enc:(fun l -> StringMap.of_seq (List.to_seq l))
175 hooks_map_jsont
176 in
177 let make hooks (unknown : Unknown.t) : initialize = { subtype = `Initialize; hooks; unknown } in
178 Jsont.Object.map ~kind:"Initialize" make
179 |> Jsont.Object.opt_mem "hooks" hooks_jsont ~enc:(fun (r : initialize) -> r.hooks)
180 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : initialize) -> r.unknown)
181 |> Jsont.Object.finish
182
183 let set_permission_mode_jsont : set_permission_mode Jsont.t =
184 let make mode (unknown : Unknown.t) : set_permission_mode = { subtype = `Set_permission_mode; mode; unknown } in
185 Jsont.Object.map ~kind:"SetPermissionMode" make
186 |> Jsont.Object.mem "mode" Permissions.Mode.jsont ~enc:(fun (r : set_permission_mode) -> r.mode)
187 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : set_permission_mode) -> r.unknown)
188 |> Jsont.Object.finish
189
190 let hook_callback_jsont : hook_callback Jsont.t =
191 let make callback_id input tool_use_id (unknown : Unknown.t) : hook_callback =
192 { subtype = `Hook_callback; callback_id; input; tool_use_id; unknown }
193 in
194 Jsont.Object.map ~kind:"HookCallback" make
195 |> Jsont.Object.mem "callback_id" Jsont.string ~enc:(fun (r : hook_callback) -> r.callback_id)
196 |> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : hook_callback) -> r.input)
197 |> Jsont.Object.opt_mem "tool_use_id" Jsont.string ~enc:(fun (r : hook_callback) -> r.tool_use_id)
198 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : hook_callback) -> r.unknown)
199 |> Jsont.Object.finish
200
201 let set_model_jsont : set_model Jsont.t =
202 let make model (unknown : Unknown.t) : set_model = { subtype = `Set_model; model; unknown } in
203 Jsont.Object.map ~kind:"SetModel" make
204 |> Jsont.Object.mem "model" Jsont.string ~enc:(fun (r : set_model) -> r.model)
205 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : set_model) -> r.unknown)
206 |> Jsont.Object.finish
207
208 let get_server_info_jsont : get_server_info Jsont.t =
209 let make (unknown : Unknown.t) : get_server_info = { subtype = `Get_server_info; unknown } in
210 Jsont.Object.map ~kind:"GetServerInfo" make
211 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : get_server_info) -> r.unknown)
212 |> Jsont.Object.finish
213
214 (* Main variant codec using subtype discriminator *)
215 let jsont : t Jsont.t =
216 let case_interrupt = Jsont.Object.Case.map "interrupt" interrupt_jsont ~dec:(fun v -> Interrupt v) in
217 let case_permission = Jsont.Object.Case.map "can_use_tool" permission_jsont ~dec:(fun v -> Permission v) in
218 let case_initialize = Jsont.Object.Case.map "initialize" initialize_jsont ~dec:(fun v -> Initialize v) in
219 let case_set_permission_mode = Jsont.Object.Case.map "set_permission_mode" set_permission_mode_jsont ~dec:(fun v -> Set_permission_mode v) in
220 let case_hook_callback = Jsont.Object.Case.map "hook_callback" hook_callback_jsont ~dec:(fun v -> Hook_callback v) in
221 let case_mcp_message = Jsont.Object.Case.map "mcp_message" Mcp_message.request_jsont ~dec:(fun v -> Mcp_message v) in
222 let case_set_model = Jsont.Object.Case.map "set_model" set_model_jsont ~dec:(fun v -> Set_model v) in
223 let case_get_server_info = Jsont.Object.Case.map "get_server_info" get_server_info_jsont ~dec:(fun v -> Get_server_info v) in
224
225 let enc_case = function
226 | Interrupt v -> Jsont.Object.Case.value case_interrupt v
227 | Permission v -> Jsont.Object.Case.value case_permission v
228 | Initialize v -> Jsont.Object.Case.value case_initialize v
229 | Set_permission_mode v -> Jsont.Object.Case.value case_set_permission_mode v
230 | Hook_callback v -> Jsont.Object.Case.value case_hook_callback v
231 | Mcp_message v -> Jsont.Object.Case.value case_mcp_message v
232 | Set_model v -> Jsont.Object.Case.value case_set_model v
233 | Get_server_info v -> Jsont.Object.Case.value case_get_server_info v
234 in
235
236 let cases = Jsont.Object.Case.[
237 make case_interrupt;
238 make case_permission;
239 make case_initialize;
240 make case_set_permission_mode;
241 make case_hook_callback;
242 make case_mcp_message;
243 make case_set_model;
244 make case_get_server_info;
245 ] in
246
247 Jsont.Object.map ~kind:"Request" Fun.id
248 |> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
249 ~tag_to_string:Fun.id ~tag_compare:String.compare
250 |> Jsont.Object.finish
251
252 let pp fmt = function
253 | Interrupt _ ->
254 Fmt.pf fmt "@[<2>Interrupt@]"
255 | Permission p ->
256 Fmt.pf fmt "@[<2>Permission@ { tool = %S;@ blocked_path = %a }@]"
257 p.tool_name Fmt.(option string) p.blocked_path
258 | Initialize i ->
259 Fmt.pf fmt "@[<2>Initialize@ { hooks = %s }@]"
260 (if Option.is_some i.hooks then "present" else "none")
261 | Set_permission_mode s ->
262 Fmt.pf fmt "@[<2>SetPermissionMode@ { mode = %a }@]"
263 Permissions.Mode.pp s.mode
264 | Hook_callback h ->
265 Fmt.pf fmt "@[<2>HookCallback@ { id = %S;@ tool_use_id = %a }@]"
266 h.callback_id Fmt.(option string) h.tool_use_id
267 | Mcp_message m ->
268 Mcp_message.pp_request fmt m
269 | Set_model s ->
270 Fmt.pf fmt "@[<2>SetModel@ { model = %S }@]" s.model
271 | Get_server_info _ ->
272 Fmt.pf fmt "@[<2>GetServerInfo@]"
273end
274
275module Response = struct
276 type success = {
277 subtype : [`Success];
278 request_id : string;
279 response : Jsont.json option;
280 unknown : Unknown.t;
281 }
282
283 type error = {
284 subtype : [`Error];
285 request_id : string;
286 error : string;
287 unknown : Unknown.t;
288 }
289
290 type t =
291 | Success of success
292 | Error of error
293
294 let success ~request_id ?response ?(unknown = Unknown.empty) () =
295 Success {
296 subtype = `Success;
297 request_id;
298 response;
299 unknown;
300 }
301
302 let error ~request_id ~error ?(unknown = Unknown.empty) () =
303 Error {
304 subtype = `Error;
305 request_id;
306 error;
307 unknown;
308 }
309
310 (* Individual record codecs *)
311 let success_jsont : success Jsont.t =
312 let make request_id response (unknown : Unknown.t) : success =
313 { subtype = `Success; request_id; response; unknown }
314 in
315 Jsont.Object.map ~kind:"Success" make
316 |> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun (r : success) -> r.request_id)
317 |> Jsont.Object.opt_mem "response" Jsont.json ~enc:(fun (r : success) -> r.response)
318 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : success) -> r.unknown)
319 |> Jsont.Object.finish
320
321 let error_jsont : error Jsont.t =
322 let make request_id error (unknown : Unknown.t) : error =
323 { subtype = `Error; request_id; error; unknown }
324 in
325 Jsont.Object.map ~kind:"Error" make
326 |> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun (r : error) -> r.request_id)
327 |> Jsont.Object.mem "error" Jsont.string ~enc:(fun (r : error) -> r.error)
328 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : error) -> r.unknown)
329 |> Jsont.Object.finish
330
331 (* Main variant codec using subtype discriminator *)
332 let jsont : t Jsont.t =
333 let case_success = Jsont.Object.Case.map "success" success_jsont ~dec:(fun v -> Success v) in
334 let case_error = Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v) in
335
336 let enc_case = function
337 | Success v -> Jsont.Object.Case.value case_success v
338 | Error v -> Jsont.Object.Case.value case_error v
339 in
340
341 let cases = Jsont.Object.Case.[
342 make case_success;
343 make case_error;
344 ] in
345
346 Jsont.Object.map ~kind:"Response" Fun.id
347 |> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
348 ~tag_to_string:Fun.id ~tag_compare:String.compare
349 |> Jsont.Object.finish
350
351 let pp fmt = function
352 | Success s ->
353 Fmt.pf fmt "@[<2>Success@ { request_id = %S;@ response = %s }@]"
354 s.request_id (if Option.is_some s.response then "present" else "none")
355 | Error e ->
356 Fmt.pf fmt "@[<2>Error@ { request_id = %S;@ error = %S }@]"
357 e.request_id e.error
358end
359
360type control_request = {
361 type_ : [`Control_request];
362 request_id : string;
363 request : Request.t;
364 unknown : Unknown.t;
365}
366
367type control_response = {
368 type_ : [`Control_response];
369 response : Response.t;
370 unknown : Unknown.t;
371}
372
373type t =
374 | Request of control_request
375 | Response of control_response
376
377let create_request ~request_id ~request ?(unknown = Unknown.empty) () =
378 Request {
379 type_ = `Control_request;
380 request_id;
381 request;
382 unknown;
383 }
384
385let create_response ~response ?(unknown = Unknown.empty) () =
386 Response {
387 type_ = `Control_response;
388 response;
389 unknown;
390 }
391
392(* Individual record codecs *)
393let control_request_jsont : control_request Jsont.t =
394 let make request_id request (unknown : Unknown.t) : control_request =
395 { type_ = `Control_request; request_id; request; unknown }
396 in
397 Jsont.Object.map ~kind:"ControlRequest" make
398 |> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun (r : control_request) -> r.request_id)
399 |> Jsont.Object.mem "request" Request.jsont ~enc:(fun (r : control_request) -> r.request)
400 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : control_request) -> r.unknown)
401 |> Jsont.Object.finish
402
403let control_response_jsont : control_response Jsont.t =
404 let make response (unknown : Unknown.t) : control_response =
405 { type_ = `Control_response; response; unknown }
406 in
407 Jsont.Object.map ~kind:"ControlResponse" make
408 |> Jsont.Object.mem "response" Response.jsont ~enc:(fun (r : control_response) -> r.response)
409 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : control_response) -> r.unknown)
410 |> Jsont.Object.finish
411
412(* Main variant codec using type discriminator *)
413let jsont : t Jsont.t =
414 let case_request = Jsont.Object.Case.map "control_request" control_request_jsont ~dec:(fun v -> Request v) in
415 let case_response = Jsont.Object.Case.map "control_response" control_response_jsont ~dec:(fun v -> Response v) in
416
417 let enc_case = function
418 | Request v -> Jsont.Object.Case.value case_request v
419 | Response v -> Jsont.Object.Case.value case_response v
420 in
421
422 let cases = Jsont.Object.Case.[
423 make case_request;
424 make case_response;
425 ] in
426
427 Jsont.Object.map ~kind:"Control" Fun.id
428 |> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
429 ~tag_to_string:Fun.id ~tag_compare:String.compare
430 |> Jsont.Object.finish
431
432let pp fmt = function
433 | Request r ->
434 Fmt.pf fmt "@[<2>ControlRequest@ { id = %S;@ request = %a }@]"
435 r.request_id Request.pp r.request
436 | Response r ->
437 Fmt.pf fmt "@[<2>ControlResponse@ { %a }@]"
438 Response.pp r.response
439
440let log_request req =
441 Log.debug (fun m -> m "SDK control request: %a" Request.pp req)
442
443let log_response resp =
444 Log.debug (fun m -> m "SDK control response: %a" Response.pp resp)
445
446(** Server information *)
447module Server_info = struct
448 type t = {
449 version : string;
450 capabilities : string list;
451 commands : string list;
452 output_styles : string list;
453 unknown : Unknown.t;
454 }
455
456 let create ~version ~capabilities ~commands ~output_styles ?(unknown = Unknown.empty) () =
457 { version; capabilities; commands; output_styles; unknown }
458
459 let version t = t.version
460 let capabilities t = t.capabilities
461 let commands t = t.commands
462 let output_styles t = t.output_styles
463 let unknown t = t.unknown
464
465 let jsont : t Jsont.t =
466 let make version capabilities commands output_styles (unknown : Unknown.t) : t =
467 { version; capabilities; commands; output_styles; unknown }
468 in
469 Jsont.Object.map ~kind:"ServerInfo" make
470 |> Jsont.Object.mem "version" Jsont.string ~enc:(fun (r : t) -> r.version)
471 |> Jsont.Object.mem "capabilities" (Jsont.list Jsont.string) ~enc:(fun (r : t) -> r.capabilities) ~dec_absent:[]
472 |> Jsont.Object.mem "commands" (Jsont.list Jsont.string) ~enc:(fun (r : t) -> r.commands) ~dec_absent:[]
473 |> Jsont.Object.mem "outputStyles" (Jsont.list Jsont.string) ~enc:(fun (r : t) -> r.output_styles) ~dec_absent:[]
474 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : t) -> r.unknown)
475 |> Jsont.Object.finish
476
477 let pp fmt t =
478 Fmt.pf fmt "@[<2>ServerInfo@ { version = %S;@ capabilities = [%a];@ commands = [%a];@ output_styles = [%a] }@]"
479 t.version
480 Fmt.(list ~sep:(any ", ") (quote string)) t.capabilities
481 Fmt.(list ~sep:(any ", ") (quote string)) t.commands
482 Fmt.(list ~sep:(any ", ") (quote string)) t.output_styles
483end