My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1let src = Logs.Src.create "claude.client" ~doc:"Claude client"
2module Log = (val Logs.src_log src : Logs.LOG)
3
4(** Control response builders using jsont *)
5module Control_response = struct
6 let success ~request_id ~response =
7 Jsont.Json.object' [
8 Jsont.Json.mem (Jsont.Json.name "type") (Jsont.Json.string "control_response");
9 Jsont.Json.mem (Jsont.Json.name "response") (Jsont.Json.object' [
10 Jsont.Json.mem (Jsont.Json.name "subtype") (Jsont.Json.string "success");
11 Jsont.Json.mem (Jsont.Json.name "request_id") (Jsont.Json.string request_id);
12 Jsont.Json.mem (Jsont.Json.name "response") response;
13 ]);
14 ]
15
16 let error ~request_id ~message =
17 Jsont.Json.object' [
18 Jsont.Json.mem (Jsont.Json.name "type") (Jsont.Json.string "control_response");
19 Jsont.Json.mem (Jsont.Json.name "response") (Jsont.Json.object' [
20 Jsont.Json.mem (Jsont.Json.name "subtype") (Jsont.Json.string "error");
21 Jsont.Json.mem (Jsont.Json.name "request_id") (Jsont.Json.string request_id);
22 Jsont.Json.mem (Jsont.Json.name "error") (Jsont.Json.string message);
23 ]);
24 ]
25end
26
27(* Helper functions for JSON manipulation using jsont *)
28let json_to_string json =
29 match Jsont_bytesrw.encode_string' Jsont.json json with
30 | Ok s -> s
31 | Error err -> failwith (Jsont.Error.to_string err)
32
33(* JSON construction helpers using jsont *)
34let json_string s = Jsont.Json.string s
35let json_null () = Jsont.Json.null ()
36
37let json_object pairs =
38 Jsont.Json.object' (List.map (fun (k, v) -> Jsont.Json.mem (Jsont.Json.name k) v) pairs)
39
40type t = {
41 transport : Transport.t;
42 permission_callback : Permissions.callback option;
43 permission_log : Permissions.Rule.t list ref option;
44 hook_callbacks : (string, Hooks.callback) Hashtbl.t;
45 mutable next_callback_id : int;
46 mutable session_id : string option;
47 control_responses : (string, Jsont.json) Hashtbl.t;
48 control_mutex : Eio.Mutex.t;
49 control_condition : Eio.Condition.t;
50}
51
52let handle_control_request t (ctrl_req : Incoming.Control_request.t) =
53 let request_id = Incoming.Control_request.request_id ctrl_req in
54 Log.info (fun m -> m "Handling control request: %s" (Incoming.Control_request.subtype ctrl_req));
55
56 match Incoming.Control_request.request ctrl_req with
57 | Incoming.Control_request.Can_use_tool req ->
58 let tool_name = Incoming.Control_request.Can_use_tool.tool_name req in
59 let input = Incoming.Control_request.Can_use_tool.input req in
60 Log.info (fun m -> m "Permission request for tool '%s' with input: %s"
61 tool_name (json_to_string input));
62 (* TODO: Parse permission_suggestions properly *)
63 let context = Permissions.Context.create ~suggestions:[] () in
64
65 Log.info (fun m -> m "Invoking permission callback for tool: %s" tool_name);
66 let result = match t.permission_callback with
67 | Some callback ->
68 Log.info (fun m -> m "Using custom permission callback");
69 callback ~tool_name ~input ~context
70 | None ->
71 Log.info (fun m -> m "Using default allow callback");
72 Permissions.default_allow_callback ~tool_name ~input ~context
73 in
74 Log.info (fun m -> m "Permission callback returned: %s"
75 (match result with
76 | Permissions.Result.Allow _ -> "ALLOW"
77 | Permissions.Result.Deny _ -> "DENY"));
78
79 (* Convert permission result to CLI format *)
80 let response_data = match result with
81 | Permissions.Result.Allow { updated_input; updated_permissions = _; unknown = _ } ->
82 let updated_input = Option.value updated_input ~default:input in
83 json_object [
84 ("behavior", json_string "allow");
85 ("updatedInput", updated_input);
86 ]
87 | Permissions.Result.Deny { message; interrupt = _; unknown = _ } ->
88 json_object [
89 ("behavior", json_string "deny");
90 ("message", json_string message);
91 ]
92 in
93 let response = Control_response.success ~request_id ~response:response_data in
94 Log.info (fun m -> m "Sending control response: %s" (json_to_string response));
95 Transport.send t.transport response
96
97 | Incoming.Control_request.Hook_callback req ->
98 let callback_id = Incoming.Control_request.Hook_callback.callback_id req in
99 let input = Incoming.Control_request.Hook_callback.input req in
100 let tool_use_id = Incoming.Control_request.Hook_callback.tool_use_id req in
101 Log.info (fun m -> m "Hook callback request for callback_id: %s" callback_id);
102
103 (try
104 let callback = Hashtbl.find t.hook_callbacks callback_id in
105 let context = Hooks.Context.create () in
106 let result = callback ~input ~tool_use_id ~context in
107
108 let result_json = match Jsont.Json.encode Hooks.result_jsont result with
109 | Ok j -> j
110 | Error msg -> failwith ("Failed to encode hook result: " ^ msg)
111 in
112 let response = Control_response.success ~request_id ~response:result_json in
113 Log.info (fun m -> m "Hook callback succeeded, sending response");
114 Transport.send t.transport response
115 with
116 | Not_found ->
117 let error_msg = Printf.sprintf "Hook callback not found: %s" callback_id in
118 Log.err (fun m -> m "%s" error_msg);
119 Transport.send t.transport (Control_response.error ~request_id ~message:error_msg)
120 | exn ->
121 let error_msg = Printf.sprintf "Hook callback error: %s" (Printexc.to_string exn) in
122 Log.err (fun m -> m "%s" error_msg);
123 Transport.send t.transport (Control_response.error ~request_id ~message:error_msg))
124
125 | Incoming.Control_request.Unknown (subtype, _) ->
126 let error_msg = Printf.sprintf "Unsupported control request: %s" subtype in
127 Transport.send t.transport (Control_response.error ~request_id ~message:error_msg)
128
129let handle_control_response t control_resp =
130 let request_id = match control_resp.Sdk_control.response with
131 | Sdk_control.Response.Success s -> s.request_id
132 | Sdk_control.Response.Error e -> e.request_id
133 in
134 Log.debug (fun m -> m "Received control response for request_id: %s" request_id);
135
136 (* Store the response as JSON and signal waiting threads *)
137 let json = match Jsont.Json.encode Sdk_control.control_response_jsont control_resp with
138 | Ok j -> j
139 | Error err -> failwith ("Failed to encode control response: " ^ err)
140 in
141 Eio.Mutex.use_rw ~protect:false t.control_mutex (fun () ->
142 Hashtbl.replace t.control_responses request_id json;
143 Eio.Condition.broadcast t.control_condition
144 )
145
146let handle_messages t =
147 let rec loop () =
148 match Transport.receive_line t.transport with
149 | None ->
150 (* EOF *)
151 Log.debug (fun m -> m "Handle messages: EOF received");
152 Seq.Nil
153 | Some line ->
154 (* Use unified Incoming codec for all message types *)
155 match Jsont_bytesrw.decode_string' Incoming.jsont line with
156 | Ok (Incoming.Message msg) ->
157 Log.info (fun m -> m "← %a" Message.pp msg);
158
159 (* Extract session ID from system messages *)
160 (match msg with
161 | Message.System sys ->
162 (match Message.System.session_id sys with
163 | Some session_id ->
164 t.session_id <- Some session_id;
165 Log.debug (fun m -> m "Stored session ID: %s" session_id)
166 | None -> ())
167 | _ -> ());
168
169 Seq.Cons (msg, loop)
170
171 | Ok (Incoming.Control_response resp) ->
172 handle_control_response t resp;
173 loop ()
174
175 | Ok (Incoming.Control_request ctrl_req) ->
176 Log.info (fun m -> m "Received control request: %s (request_id: %s)"
177 (Incoming.Control_request.subtype ctrl_req)
178 (Incoming.Control_request.request_id ctrl_req));
179 handle_control_request t ctrl_req;
180 loop ()
181
182 | Error err ->
183 Log.err (fun m -> m "Failed to decode incoming message: %s\nLine: %s"
184 (Jsont.Error.to_string err) line);
185 loop ()
186 in
187 Log.debug (fun m -> m "Starting message handler");
188 loop
189
190let create ?(options = Options.default) ~sw ~process_mgr () =
191 (* Automatically enable permission prompt tool when callback is configured
192 (matching Python SDK behavior in client.py:104-121) *)
193 let options =
194 match Options.permission_callback options with
195 | Some _ when Options.permission_prompt_tool_name options = None ->
196 (* Set permission_prompt_tool_name to "stdio" to enable control protocol *)
197 Options.with_permission_prompt_tool_name "stdio" options
198 | _ -> options
199 in
200 let transport = Transport.create ~sw ~process_mgr ~options () in
201
202 (* Setup hook callbacks *)
203 let hook_callbacks = Hashtbl.create 16 in
204 let next_callback_id = ref 0 in
205
206 let t = {
207 transport;
208 permission_callback = Options.permission_callback options;
209 permission_log = None;
210 hook_callbacks;
211 next_callback_id = 0;
212 session_id = None;
213 control_responses = Hashtbl.create 16;
214 control_mutex = Eio.Mutex.create ();
215 control_condition = Eio.Condition.create ();
216 } in
217
218 (* Register hooks and send initialize if hooks are configured *)
219 (match Options.hooks options with
220 | Some hooks_config ->
221 Log.info (fun m -> m "Registering hooks...");
222
223 (* Build hooks configuration with callback IDs *)
224 let hooks_json = List.fold_left (fun acc (event, matchers) ->
225 let event_name = Hooks.event_to_string event in
226 let matchers_json = List.map (fun matcher ->
227 let callback_ids = List.map (fun callback ->
228 let callback_id = Printf.sprintf "hook_%d" !next_callback_id in
229 incr next_callback_id;
230 Hashtbl.add hook_callbacks callback_id callback;
231 Log.debug (fun m -> m "Registered callback: %s for event: %s" callback_id event_name);
232 callback_id
233 ) matcher.Hooks.callbacks in
234 json_object [
235 "matcher", (match matcher.Hooks.matcher with
236 | Some p -> json_string p
237 | None -> json_null ());
238 "hookCallbackIds", Jsont.Json.list (List.map (fun id -> json_string id) callback_ids);
239 ]
240 ) matchers in
241 (event_name, Jsont.Json.list matchers_json) :: acc
242 ) [] hooks_config in
243
244 (* Send initialize control request *)
245 let initialize_msg = json_object [
246 "type", json_string "control_request";
247 "request_id", json_string "init_hooks";
248 "request", json_object [
249 "subtype", json_string "initialize";
250 "hooks", json_object hooks_json;
251 ]
252 ] in
253 Log.info (fun m -> m "Sending hooks initialize request");
254 Transport.send t.transport initialize_msg;
255 t.next_callback_id <- !next_callback_id
256 | None -> ());
257
258 t
259
260let query t prompt =
261 let msg = Message.user_string prompt in
262 Log.info (fun m -> m "→ %a" Message.pp msg);
263 let json = Message.to_json msg in
264 Transport.send t.transport json
265
266let send_message t msg =
267 Log.info (fun m -> m "→ %a" Message.pp msg);
268 let json = Message.to_json msg in
269 Transport.send t.transport json
270
271let send_user_message t user_msg =
272 let msg = Message.User user_msg in
273 Log.info (fun m -> m "→ %a" Message.pp msg);
274 let json = Message.User.to_json user_msg in
275 Transport.send t.transport json
276
277let receive t =
278 handle_messages t
279
280let receive_all t =
281 let rec collect acc seq =
282 match seq () with
283 | Seq.Nil ->
284 Log.debug (fun m -> m "End of message sequence (%d messages)" (List.length acc));
285 List.rev acc
286 | Seq.Cons (Message.Result _ as msg, _) ->
287 Log.debug (fun m -> m "Received final Result message");
288 List.rev (msg :: acc)
289 | Seq.Cons (msg, rest) ->
290 collect (msg :: acc) rest
291 in
292 collect [] (handle_messages t)
293
294let interrupt t =
295 Transport.interrupt t.transport
296
297let discover_permissions t =
298 let log = ref [] in
299 let callback = Permissions.discovery_callback log in
300 { t with
301 permission_callback = Some callback;
302 permission_log = Some log
303 }
304
305let get_discovered_permissions t =
306 match t.permission_log with
307 | Some log -> !log
308 | None -> []
309
310let with_permission_callback t callback =
311 { t with permission_callback = Some callback }
312
313(* Helper to send a control request and wait for response *)
314let send_control_request t ~request_id request =
315 (* Send the control request *)
316 let control_msg = Sdk_control.create_request ~request_id ~request () in
317 let json = match Jsont.Json.encode Sdk_control.jsont control_msg with
318 | Ok j -> j
319 | Error msg -> failwith ("Failed to encode control request: " ^ msg)
320 in
321 Log.info (fun m -> m "Sending control request: %s" (json_to_string json));
322 Transport.send t.transport json;
323
324 (* Wait for the response with timeout *)
325 let max_wait = 10.0 in (* 10 seconds timeout *)
326 let start_time = Unix.gettimeofday () in
327
328 let rec wait_for_response () =
329 Eio.Mutex.use_rw ~protect:false t.control_mutex (fun () ->
330 match Hashtbl.find_opt t.control_responses request_id with
331 | Some response_json ->
332 (* Remove it from the table *)
333 Hashtbl.remove t.control_responses request_id;
334 response_json
335 | None ->
336 let elapsed = Unix.gettimeofday () -. start_time in
337 if elapsed > max_wait then
338 raise (Failure (Printf.sprintf "Timeout waiting for control response: %s" request_id))
339 else (
340 (* Release mutex and wait for signal *)
341 Eio.Condition.await_no_mutex t.control_condition;
342 wait_for_response ()
343 )
344 )
345 in
346
347 let response_json = wait_for_response () in
348 Log.debug (fun m -> m "Received control response: %s" (json_to_string response_json));
349
350 (* Parse the response - extract the "response" field using jsont codec *)
351 let response_field_codec = Jsont.Object.map ~kind:"ResponseField" Fun.id
352 |> Jsont.Object.mem "response" Jsont.json ~enc:Fun.id
353 |> Jsont.Object.finish
354 in
355 let response_data = match Jsont.Json.decode response_field_codec response_json with
356 | Ok r -> r
357 | Error msg -> raise (Invalid_argument ("Failed to extract response field: " ^ msg))
358 in
359 let response = match Jsont.Json.decode Sdk_control.Response.jsont response_data with
360 | Ok r -> r
361 | Error msg -> raise (Invalid_argument ("Failed to decode response: " ^ msg))
362 in
363 match response with
364 | Sdk_control.Response.Success s -> s.response
365 | Sdk_control.Response.Error e ->
366 raise (Failure (Printf.sprintf "Control request failed: %s" e.error))
367
368let set_permission_mode t mode =
369 let request_id = Printf.sprintf "set_perm_mode_%f" (Unix.gettimeofday ()) in
370 let request = Sdk_control.Request.set_permission_mode ~mode () in
371 let _response = send_control_request t ~request_id request in
372 Log.info (fun m -> m "Permission mode set to: %a" Permissions.Mode.pp mode)
373
374let set_model t model =
375 let model_str = Model.to_string model in
376 let request_id = Printf.sprintf "set_model_%f" (Unix.gettimeofday ()) in
377 let request = Sdk_control.Request.set_model ~model:model_str () in
378 let _response = send_control_request t ~request_id request in
379 Log.info (fun m -> m "Model set to: %a" Model.pp model)
380
381let set_model_string t model_str =
382 set_model t (Model.of_string model_str)
383
384let get_server_info t =
385 let request_id = Printf.sprintf "get_server_info_%f" (Unix.gettimeofday ()) in
386 let request = Sdk_control.Request.get_server_info () in
387 match send_control_request t ~request_id request with
388 | Some response_data ->
389 let server_info = match Jsont.Json.decode Sdk_control.Server_info.jsont response_data with
390 | Ok si -> si
391 | Error msg -> raise (Invalid_argument ("Failed to decode server info: " ^ msg))
392 in
393 Log.info (fun m -> m "Retrieved server info: %a" Sdk_control.Server_info.pp server_info);
394 server_info
395 | None ->
396 raise (Failure "No response data from get_server_info request")