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