My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1open Eio.Std
2
3let src = Logs.Src.create "claude.transport" ~doc:"Claude transport layer"
4module Log = (val Logs.src_log src : Logs.LOG)
5
6exception CLI_not_found of string
7exception Process_error of string
8exception Connection_error of string
9
10type process = P : _ Eio.Process.t -> process
11
12type t = {
13 process : process;
14 stdin : Eio.Flow.sink_ty r;
15 stdin_close : [`Close | `Flow] r;
16 stdout : Eio.Buf_read.t;
17 sw : Switch.t;
18}
19
20let setting_source_to_string = function
21 | Options.User -> "user"
22 | Options.Project -> "project"
23 | Options.Local -> "local"
24
25(* Helper functions for JSON construction *)
26let json_string s = Jsont.String (s, Jsont.Meta.none)
27
28let json_array items =
29 Jsont.Array (items, Jsont.Meta.none)
30
31let json_object members =
32 Jsont.Object (
33 List.map (fun (k, v) -> ((k, Jsont.Meta.none), v)) members,
34 Jsont.Meta.none
35 )
36
37(* Serialize MCP server configuration to JSON string *)
38let serialize_mcp_config (servers : (string * Options.mcp_server_config) list) : string =
39 (* Serialize environment variables as JSON object *)
40 let serialize_env env_vars =
41 json_object (List.map (fun (k, v) -> (k, json_string v)) env_vars)
42 in
43
44 (* Serialize headers as JSON object *)
45 let serialize_headers headers =
46 json_object (List.map (fun (k, v) -> (k, json_string v)) headers)
47 in
48
49 (* Convert each server config to JSON *)
50 let server_jsons = List.map (fun (name, config) ->
51 let config_json = match config with
52 | Options.Stdio { command; args; env } ->
53 let members = [
54 ("command", json_string command);
55 ("args", json_array (List.map json_string args));
56 ] in
57 let members = match env with
58 | None -> members
59 | Some env_vars -> members @ [("env", serialize_env env_vars)]
60 in
61 json_object members
62
63 | Options.SSE { url; headers } ->
64 let members = [
65 ("type", json_string "sse");
66 ("url", json_string url);
67 ] in
68 let members = match headers with
69 | None -> members
70 | Some hdrs -> members @ [("headers", serialize_headers hdrs)]
71 in
72 json_object members
73
74 | Options.HTTP { url; headers } ->
75 let members = [
76 ("type", json_string "http");
77 ("url", json_string url);
78 ] in
79 let members = match headers with
80 | None -> members
81 | Some hdrs -> members @ [("headers", serialize_headers hdrs)]
82 in
83 json_object members
84 in
85 ((name, Jsont.Meta.none), config_json)
86 ) servers in
87
88 (* Build full config object: {"mcpServers": {...}} *)
89 let mcp_servers_obj = Jsont.Object (server_jsons, Jsont.Meta.none) in
90 let full_config = Jsont.Object ([
91 (("mcpServers", Jsont.Meta.none), mcp_servers_obj)
92 ], Jsont.Meta.none) in
93
94 (* Encode to string *)
95 match Jsont_bytesrw.encode_string' Jsont.json full_config with
96 | Ok s -> s
97 | Error err -> failwith ("Failed to encode MCP config: " ^ Jsont.Error.to_string err)
98
99let build_command ~claude_path ~options =
100 let cmd = [claude_path; "--output-format"; "stream-json"; "--verbose"] in
101
102 let cmd = match Options.system_prompt options with
103 | Some prompt -> cmd @ ["--system-prompt"; prompt]
104 | None -> cmd
105 in
106
107 let cmd = match Options.append_system_prompt options with
108 | Some prompt -> cmd @ ["--append-system-prompt"; prompt]
109 | None -> cmd
110 in
111
112 let cmd = match Options.allowed_tools options with
113 | [] -> cmd
114 | tools -> cmd @ ["--allowedTools"; String.concat "," tools]
115 in
116
117 let cmd = match Options.disallowed_tools options with
118 | [] -> cmd
119 | tools -> cmd @ ["--disallowedTools"; String.concat "," tools]
120 in
121
122 let cmd = match Options.model options with
123 | Some model -> cmd @ ["--model"; Model.to_string model]
124 | None -> cmd
125 in
126
127 let cmd = match Options.permission_mode options with
128 | Some mode ->
129 let mode_str = Permissions.Mode.to_string mode in
130 cmd @ ["--permission-mode"; mode_str]
131 | None -> cmd
132 in
133
134 let cmd = match Options.permission_prompt_tool_name options with
135 | Some tool_name -> cmd @ ["--permission-prompt-tool"; tool_name]
136 | None -> cmd
137 in
138
139 (* Advanced configuration options *)
140 let cmd = match Options.max_budget_usd options with
141 | Some budget -> cmd @ ["--max-budget-usd"; Float.to_string budget]
142 | None -> cmd
143 in
144
145 let cmd = match Options.fallback_model options with
146 | Some model -> cmd @ ["--fallback-model"; Model.to_string model]
147 | None -> cmd
148 in
149
150 let cmd = match Options.setting_sources options with
151 | Some sources ->
152 let sources_str = String.concat "," (List.map setting_source_to_string sources) in
153 cmd @ ["--setting-sources"; sources_str]
154 | None -> cmd
155 in
156
157 (* Add JSON Schema if specified *)
158 let cmd = match Options.output_format options with
159 | Some format ->
160 let schema = Structured_output.json_schema format in
161 let schema_str = match Jsont_bytesrw.encode_string' Jsont.json schema with
162 | Ok s -> s
163 | Error err -> failwith (Jsont.Error.to_string err)
164 in
165 cmd @ ["--json-schema"; schema_str]
166 | None -> cmd
167 in
168
169 (* MCP Server Configuration *)
170 let cmd =
171 if Options.mcp_servers options = [] then cmd
172 else
173 let mcp_config_json = serialize_mcp_config (Options.mcp_servers options) in
174 cmd @ ["--mcp-config"; mcp_config_json]
175 in
176
177 (* Use streaming input mode *)
178 cmd @ ["--input-format"; "stream-json"]
179
180let create ~sw ~process_mgr ~options () =
181 let claude_path = "claude" in
182 let cmd = build_command ~claude_path ~options in
183
184 (* Build environment - preserve essential vars for Claude config/auth access *)
185 let home = try Unix.getenv "HOME" with Not_found -> "/tmp" in
186 let path = try Unix.getenv "PATH" with Not_found -> "/usr/bin:/bin" in
187
188 (* Preserve other potentially important environment variables *)
189 let preserve_vars = [
190 "USER"; "LOGNAME"; "SHELL"; "TERM";
191 "XDG_CONFIG_HOME"; "XDG_DATA_HOME"; "XDG_CACHE_HOME";
192 "ANTHROPIC_API_KEY"; "CLAUDE_API_KEY" (* In case API key is set via env *)
193 ] in
194
195 let preserved = List.filter_map (fun var ->
196 try Some (Printf.sprintf "%s=%s" var (Unix.getenv var))
197 with Not_found -> None
198 ) preserve_vars in
199
200 let base_env = [
201 Printf.sprintf "HOME=%s" home;
202 Printf.sprintf "PATH=%s" path;
203 "CLAUDE_CODE_ENTRYPOINT=sdk-ocaml";
204 ] @ preserved in
205
206 let custom_env = List.map (fun (k, v) -> Printf.sprintf "%s=%s" k v) (Options.env options) in
207 let env = Array.of_list (base_env @ custom_env) in
208 Log.debug (fun m -> m "Environment: HOME=%s, PATH=%s" home path);
209 Log.info (fun m -> m "Full environment variables: %s" (String.concat ", " (Array.to_list env)));
210
211 let stdin_r, stdin_w = Eio.Process.pipe ~sw process_mgr in
212 let stdout_r, stdout_w = Eio.Process.pipe ~sw process_mgr in
213 let stderr_r, stderr_w = Eio.Process.pipe ~sw process_mgr in
214 (* Close stderr pipes - we don't need them *)
215 Eio.Flow.close stderr_r;
216 Eio.Flow.close stderr_w;
217
218 let process =
219 try
220 Log.info (fun m -> m "Spawning claude with command: %s" (String.concat " " cmd));
221 Log.info (fun m -> m "Command arguments breakdown:");
222 List.iteri (fun i arg ->
223 Log.info (fun m -> m " [%d]: %s" i arg)
224 ) cmd;
225 Eio.Process.spawn ~sw process_mgr
226 ~env
227 ~stdin:(stdin_r :> Eio.Flow.source_ty r)
228 ~stdout:(stdout_w :> Eio.Flow.sink_ty r)
229 ?cwd:(Options.cwd options)
230 cmd
231 with
232 | exn ->
233 Log.err (fun m -> m "Failed to spawn claude CLI: %s" (Printexc.to_string exn));
234 Log.err (fun m -> m "Make sure 'claude' is installed and authenticated");
235 Log.err (fun m -> m "You may need to run 'claude login' first");
236 raise (CLI_not_found (Printf.sprintf "Failed to spawn claude CLI: %s" (Printexc.to_string exn)))
237 in
238
239 let stdin = (stdin_w :> Eio.Flow.sink_ty r) in
240 let stdin_close = (stdin_w :> [`Close | `Flow] r) in
241 let max_size = match Options.max_buffer_size options with
242 | Some size -> size
243 | None -> 1_000_000 (* Default 1MB *)
244 in
245 let stdout = Eio.Buf_read.of_flow ~max_size (stdout_r :> Eio.Flow.source_ty r) in
246
247 { process = P process; stdin; stdin_close; stdout; sw }
248
249let send t json =
250 let data = match Jsont_bytesrw.encode_string' Jsont.json json with
251 | Ok s -> s
252 | Error err -> failwith (Jsont.Error.to_string err)
253 in
254 Log.debug (fun m -> m "Sending: %s" data);
255 try
256 Eio.Flow.write t.stdin [Cstruct.of_string (data ^ "\n")]
257 with
258 | exn ->
259 Log.err (fun m -> m "Failed to send message: %s" (Printexc.to_string exn));
260 raise (Connection_error (Printf.sprintf "Failed to send message: %s" (Printexc.to_string exn)))
261
262let receive_line t =
263 try
264 match Eio.Buf_read.line t.stdout with
265 | line ->
266 Log.debug (fun m -> m "Raw JSON: %s" line);
267 Some line
268 | exception End_of_file ->
269 Log.debug (fun m -> m "Received EOF");
270 None
271 with
272 | exn ->
273 Log.err (fun m -> m "Failed to receive message: %s" (Printexc.to_string exn));
274 raise (Connection_error (Printf.sprintf "Failed to receive message: %s" (Printexc.to_string exn)))
275
276let interrupt t =
277 Log.info (fun m -> m "Sending interrupt signal");
278 let interrupt_msg =
279 Jsont.Json.object' [
280 Jsont.Json.mem (Jsont.Json.name "type") (Jsont.Json.string "control_response");
281 Jsont.Json.mem (Jsont.Json.name "response") (Jsont.Json.object' [
282 Jsont.Json.mem (Jsont.Json.name "subtype") (Jsont.Json.string "interrupt");
283 Jsont.Json.mem (Jsont.Json.name "request_id") (Jsont.Json.string "");
284 ])
285 ]
286 in
287 send t interrupt_msg
288
289let close t =
290 try
291 Eio.Flow.close t.stdin_close;
292 let (P process) = t.process in
293 Eio.Process.await_exn process
294 with _ -> ()