···
+
let src = Logs.Src.create "claude.sdk_control" ~doc:"Claude SDK control protocol"
+
module Log = (val Logs.src_log src : Logs.LOG)
+
module Request = struct
+
subtype : [`Interrupt];
+
subtype : [`Can_use_tool];
+
permission_suggestions : Permissions.Update.t list option;
+
blocked_path : string option;
+
subtype : [`Initialize];
+
hooks : (string * value) list option;
+
type set_permission_mode = {
+
subtype : [`Set_permission_mode];
+
mode : Permissions.Mode.t;
+
subtype : [`Hook_callback];
+
tool_use_id : string option;
+
subtype : [`Mcp_message];
+
| Interrupt of interrupt
+
| Permission of permission
+
| Initialize of initialize
+
| Set_permission_mode of set_permission_mode
+
| Hook_callback of hook_callback
+
| Mcp_message of mcp_message
+
let interrupt () = Interrupt { subtype = `Interrupt }
+
let permission ~tool_name ~input ?permission_suggestions ?blocked_path () =
+
subtype = `Can_use_tool;
+
permission_suggestions;
+
let initialize ?hooks () =
+
Initialize { subtype = `Initialize; hooks }
+
let set_permission_mode ~mode =
+
Set_permission_mode { subtype = `Set_permission_mode; mode }
+
let hook_callback ~callback_id ~input ?tool_use_id () =
+
subtype = `Hook_callback;
+
let mcp_message ~server_name ~message =
+
subtype = `Mcp_message;
+
`O [("subtype", `String "interrupt")]
+
("subtype", `String "can_use_tool");
+
("tool_name", `String p.tool_name);
+
let fields = match p.permission_suggestions with
+
("permission_suggestions",
+
`A (List.map Permissions.Update.to_json suggestions)) :: fields
+
let fields = match p.blocked_path with
+
| Some path -> ("blocked_path", `String path) :: fields
+
let fields = [("subtype", `String "initialize")] in
+
let fields = match i.hooks with
+
("hooks", `O hooks) :: fields
+
| Set_permission_mode s ->
+
("subtype", `String "set_permission_mode");
+
("mode", Permissions.Mode.to_json s.mode);
+
("subtype", `String "hook_callback");
+
("callback_id", `String h.callback_id);
+
let fields = match h.tool_use_id with
+
| Some id -> ("tool_use_id", `String id) :: fields
+
("subtype", `String "mcp_message");
+
("server_name", `String m.server_name);
+
("message", m.message);
+
let subtype = JU.assoc_string "subtype" fields in
+
Interrupt { subtype = `Interrupt }
+
let tool_name = JU.assoc_string "tool_name" fields in
+
let input = List.assoc "input" fields in
+
let permission_suggestions =
+
match List.assoc_opt "permission_suggestions" fields with
+
Some (List.map Permissions.Update.of_json lst)
+
let blocked_path = JU.assoc_string_opt "blocked_path" fields in
+
subtype = `Can_use_tool;
+
permission_suggestions;
+
match List.assoc_opt "hooks" fields with
+
| Some (`O hooks) -> Some hooks
+
Initialize { subtype = `Initialize; hooks }
+
| "set_permission_mode" ->
+
let mode = List.assoc "mode" fields |> Permissions.Mode.of_json in
+
Set_permission_mode { subtype = `Set_permission_mode; mode }
+
let callback_id = JU.assoc_string "callback_id" fields in
+
let input = List.assoc "input" fields in
+
let tool_use_id = JU.assoc_string_opt "tool_use_id" fields in
+
subtype = `Hook_callback;
+
let server_name = JU.assoc_string "server_name" fields in
+
let message = List.assoc "message" fields in
+
subtype = `Mcp_message;
+
| _ -> raise (Invalid_argument ("Unknown request subtype: " ^ subtype)))
+
| _ -> raise (Invalid_argument "Request.of_json: expected object")
+
Fmt.pf fmt "@[<2>Interrupt@]"
+
Fmt.pf fmt "@[<2>Permission@ { tool = %S;@ blocked_path = %a }@]"
+
p.tool_name Fmt.(option string) p.blocked_path
+
Fmt.pf fmt "@[<2>Initialize@ { hooks = %s }@]"
+
(if Option.is_some i.hooks then "present" else "none")
+
| Set_permission_mode s ->
+
Fmt.pf fmt "@[<2>SetPermissionMode@ { mode = %a }@]"
+
Permissions.Mode.pp s.mode
+
Fmt.pf fmt "@[<2>HookCallback@ { id = %S;@ tool_use_id = %a }@]"
+
h.callback_id Fmt.(option string) h.tool_use_id
+
Fmt.pf fmt "@[<2>McpMessage@ { server = %S }@]"
+
module Response = struct
+
response : value option;
+
let success ~request_id ?response () =
+
let error ~request_id ~error =
+
("subtype", `String "success");
+
("request_id", `String s.request_id);
+
let fields = match s.response with
+
| Some resp -> ("response", resp) :: fields
+
("subtype", `String "error");
+
("request_id", `String e.request_id);
+
("error", `String e.error);
+
let subtype = JU.assoc_string "subtype" fields in
+
let request_id = JU.assoc_string "request_id" fields in
+
let response = List.assoc_opt "response" fields in
+
let error = JU.assoc_string "error" fields in
+
| _ -> raise (Invalid_argument ("Unknown response subtype: " ^ subtype)))
+
| _ -> raise (Invalid_argument "Response.of_json: expected object")
+
Fmt.pf fmt "@[<2>Success@ { request_id = %S;@ response = %s }@]"
+
s.request_id (if Option.is_some s.response then "present" else "none")
+
Fmt.pf fmt "@[<2>Error@ { request_id = %S;@ error = %S }@]"
+
type control_request = {
+
type_ : [`Control_request];
+
type control_response = {
+
type_ : [`Control_response];
+
| Request of control_request
+
| Response of control_response
+
let create_request ~request_id ~request =
+
type_ = `Control_request;
+
let create_response ~response =
+
type_ = `Control_response;
+
("type", `String "control_request");
+
("request_id", `String r.request_id);
+
("request", Request.to_json r.request);
+
("type", `String "control_response");
+
("response", Response.to_json r.response);
+
let type_ = JU.assoc_string "type" fields in
+
let request_id = JU.assoc_string "request_id" fields in
+
let request = List.assoc "request" fields |> Request.of_json in
+
type_ = `Control_request;
+
| "control_response" ->
+
let response = List.assoc "response" fields |> Response.of_json in
+
type_ = `Control_response;
+
| _ -> raise (Invalid_argument ("Unknown control type: " ^ type_)))
+
| _ -> raise (Invalid_argument "of_json: expected object")
+
Fmt.pf fmt "@[<2>ControlRequest@ { id = %S;@ request = %a }@]"
+
r.request_id Request.pp r.request
+
Fmt.pf fmt "@[<2>ControlResponse@ { %a }@]"
+
Log.debug (fun m -> m "SDK control request: %a" Request.pp req)
+
let log_response resp =
+
Log.debug (fun m -> m "SDK control response: %a" Response.pp resp)
anil.recoil.org