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 t =
45 | Interrupt of interrupt
46 | Permission of permission
47 | Initialize of initialize
48 | Set_permission_mode of set_permission_mode
49 | Hook_callback of hook_callback
50 | Mcp_message of mcp_message
51
52 let interrupt () = Interrupt { subtype = `Interrupt }
53
54 let permission ~tool_name ~input ?permission_suggestions ?blocked_path () =
55 Permission {
56 subtype = `Can_use_tool;
57 tool_name;
58 input;
59 permission_suggestions;
60 blocked_path;
61 }
62
63 let initialize ?hooks () =
64 Initialize { subtype = `Initialize; hooks }
65
66 let set_permission_mode ~mode =
67 Set_permission_mode { subtype = `Set_permission_mode; mode }
68
69 let hook_callback ~callback_id ~input ?tool_use_id () =
70 Hook_callback {
71 subtype = `Hook_callback;
72 callback_id;
73 input;
74 tool_use_id;
75 }
76
77 let mcp_message ~server_name ~message =
78 Mcp_message {
79 subtype = `Mcp_message;
80 server_name;
81 message;
82 }
83
84 let to_json = function
85 | Interrupt _ ->
86 `O [("subtype", `String "interrupt")]
87 | Permission p ->
88 let fields = [
89 ("subtype", `String "can_use_tool");
90 ("tool_name", `String p.tool_name);
91 ("input", p.input);
92 ] in
93 let fields = match p.permission_suggestions with
94 | Some suggestions ->
95 ("permission_suggestions",
96 `A (List.map Permissions.Update.to_json suggestions)) :: fields
97 | None -> fields
98 in
99 let fields = match p.blocked_path with
100 | Some path -> ("blocked_path", `String path) :: fields
101 | None -> fields
102 in
103 `O fields
104 | Initialize i ->
105 let fields = [("subtype", `String "initialize")] in
106 let fields = match i.hooks with
107 | Some hooks ->
108 ("hooks", `O hooks) :: fields
109 | None -> fields
110 in
111 `O fields
112 | Set_permission_mode s ->
113 `O [
114 ("subtype", `String "set_permission_mode");
115 ("mode", Permissions.Mode.to_json s.mode);
116 ]
117 | Hook_callback h ->
118 let fields = [
119 ("subtype", `String "hook_callback");
120 ("callback_id", `String h.callback_id);
121 ("input", h.input);
122 ] in
123 let fields = match h.tool_use_id with
124 | Some id -> ("tool_use_id", `String id) :: fields
125 | None -> fields
126 in
127 `O fields
128 | Mcp_message m ->
129 `O [
130 ("subtype", `String "mcp_message");
131 ("server_name", `String m.server_name);
132 ("message", m.message);
133 ]
134
135 let of_json = function
136 | `O fields ->
137 let subtype = JU.assoc_string "subtype" fields in
138 (match subtype with
139 | "interrupt" ->
140 Interrupt { subtype = `Interrupt }
141 | "can_use_tool" ->
142 let tool_name = JU.assoc_string "tool_name" fields in
143 let input = List.assoc "input" fields in
144 let permission_suggestions =
145 match List.assoc_opt "permission_suggestions" fields with
146 | Some (`A lst) ->
147 Some (List.map Permissions.Update.of_json lst)
148 | _ -> None
149 in
150 let blocked_path = JU.assoc_string_opt "blocked_path" fields in
151 Permission {
152 subtype = `Can_use_tool;
153 tool_name;
154 input;
155 permission_suggestions;
156 blocked_path;
157 }
158 | "initialize" ->
159 let hooks =
160 match List.assoc_opt "hooks" fields with
161 | Some (`O hooks) -> Some hooks
162 | _ -> None
163 in
164 Initialize { subtype = `Initialize; hooks }
165 | "set_permission_mode" ->
166 let mode = List.assoc "mode" fields |> Permissions.Mode.of_json in
167 Set_permission_mode { subtype = `Set_permission_mode; mode }
168 | "hook_callback" ->
169 let callback_id = JU.assoc_string "callback_id" fields in
170 let input = List.assoc "input" fields in
171 let tool_use_id = JU.assoc_string_opt "tool_use_id" fields in
172 Hook_callback {
173 subtype = `Hook_callback;
174 callback_id;
175 input;
176 tool_use_id;
177 }
178 | "mcp_message" ->
179 let server_name = JU.assoc_string "server_name" fields in
180 let message = List.assoc "message" fields in
181 Mcp_message {
182 subtype = `Mcp_message;
183 server_name;
184 message;
185 }
186 | _ -> raise (Invalid_argument ("Unknown request subtype: " ^ subtype)))
187 | _ -> raise (Invalid_argument "Request.of_json: expected object")
188
189 let pp fmt = function
190 | Interrupt _ ->
191 Fmt.pf fmt "@[<2>Interrupt@]"
192 | Permission p ->
193 Fmt.pf fmt "@[<2>Permission@ { tool = %S;@ blocked_path = %a }@]"
194 p.tool_name Fmt.(option string) p.blocked_path
195 | Initialize i ->
196 Fmt.pf fmt "@[<2>Initialize@ { hooks = %s }@]"
197 (if Option.is_some i.hooks then "present" else "none")
198 | Set_permission_mode s ->
199 Fmt.pf fmt "@[<2>SetPermissionMode@ { mode = %a }@]"
200 Permissions.Mode.pp s.mode
201 | Hook_callback h ->
202 Fmt.pf fmt "@[<2>HookCallback@ { id = %S;@ tool_use_id = %a }@]"
203 h.callback_id Fmt.(option string) h.tool_use_id
204 | Mcp_message m ->
205 Fmt.pf fmt "@[<2>McpMessage@ { server = %S }@]"
206 m.server_name
207end
208
209module Response = struct
210 type success = {
211 subtype : [`Success];
212 request_id : string;
213 response : value option;
214 }
215
216 type error = {
217 subtype : [`Error];
218 request_id : string;
219 error : string;
220 }
221
222 type t =
223 | Success of success
224 | Error of error
225
226 let success ~request_id ?response () =
227 Success {
228 subtype = `Success;
229 request_id;
230 response;
231 }
232
233 let error ~request_id ~error =
234 Error {
235 subtype = `Error;
236 request_id;
237 error;
238 }
239
240 let to_json = function
241 | Success s ->
242 let fields = [
243 ("subtype", `String "success");
244 ("request_id", `String s.request_id);
245 ] in
246 let fields = match s.response with
247 | Some resp -> ("response", resp) :: fields
248 | None -> fields
249 in
250 `O fields
251 | Error e ->
252 `O [
253 ("subtype", `String "error");
254 ("request_id", `String e.request_id);
255 ("error", `String e.error);
256 ]
257
258 let of_json = function
259 | `O fields ->
260 let subtype = JU.assoc_string "subtype" fields in
261 let request_id = JU.assoc_string "request_id" fields in
262 (match subtype with
263 | "success" ->
264 let response = List.assoc_opt "response" fields in
265 Success {
266 subtype = `Success;
267 request_id;
268 response;
269 }
270 | "error" ->
271 let error = JU.assoc_string "error" fields in
272 Error {
273 subtype = `Error;
274 request_id;
275 error;
276 }
277 | _ -> raise (Invalid_argument ("Unknown response subtype: " ^ subtype)))
278 | _ -> raise (Invalid_argument "Response.of_json: expected object")
279
280 let pp fmt = function
281 | Success s ->
282 Fmt.pf fmt "@[<2>Success@ { request_id = %S;@ response = %s }@]"
283 s.request_id (if Option.is_some s.response then "present" else "none")
284 | Error e ->
285 Fmt.pf fmt "@[<2>Error@ { request_id = %S;@ error = %S }@]"
286 e.request_id e.error
287end
288
289type control_request = {
290 type_ : [`Control_request];
291 request_id : string;
292 request : Request.t;
293}
294
295type control_response = {
296 type_ : [`Control_response];
297 response : Response.t;
298}
299
300type t =
301 | Request of control_request
302 | Response of control_response
303
304let create_request ~request_id ~request =
305 Request {
306 type_ = `Control_request;
307 request_id;
308 request;
309 }
310
311let create_response ~response =
312 Response {
313 type_ = `Control_response;
314 response;
315 }
316
317let to_json = function
318 | Request r ->
319 `O [
320 ("type", `String "control_request");
321 ("request_id", `String r.request_id);
322 ("request", Request.to_json r.request);
323 ]
324 | Response r ->
325 `O [
326 ("type", `String "control_response");
327 ("response", Response.to_json r.response);
328 ]
329
330let of_json = function
331 | `O fields ->
332 let type_ = JU.assoc_string "type" fields in
333 (match type_ with
334 | "control_request" ->
335 let request_id = JU.assoc_string "request_id" fields in
336 let request = List.assoc "request" fields |> Request.of_json in
337 Request {
338 type_ = `Control_request;
339 request_id;
340 request;
341 }
342 | "control_response" ->
343 let response = List.assoc "response" fields |> Response.of_json in
344 Response {
345 type_ = `Control_response;
346 response;
347 }
348 | _ -> raise (Invalid_argument ("Unknown control type: " ^ type_)))
349 | _ -> raise (Invalid_argument "of_json: expected object")
350
351let pp fmt = function
352 | Request r ->
353 Fmt.pf fmt "@[<2>ControlRequest@ { id = %S;@ request = %a }@]"
354 r.request_id Request.pp r.request
355 | Response r ->
356 Fmt.pf fmt "@[<2>ControlResponse@ { %a }@]"
357 Response.pp r.response
358
359let log_request req =
360 Log.debug (fun m -> m "SDK control request: %a" Request.pp req)
361
362let log_response resp =
363 Log.debug (fun m -> m "SDK control response: %a" Response.pp resp)