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