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