anil.recoil.org
OCaml Claude SDK using Eio and Jsont
ocamlformat and cleanup
+2767
-2288
+1
-1
lib/claude.ml
+1
-1
lib/claude.ml
+57
-54
lib/claude.mli
+57
-54
lib/claude.mli
···
17
17
18
18
The library is structured into several focused modules:
19
19
20
-
- {!Content_block}: Defines content blocks (text, tool use, tool results, thinking)
21
-
- {!Message}: Messages exchanged with Claude (user, assistant, system, result)
20
+
- {!Content_block}: Defines content blocks (text, tool use, tool results,
21
+
thinking)
22
+
- {!Message}: Messages exchanged with Claude (user, assistant, system,
23
+
result)
22
24
- {!Control}: Control flow messages for session management
23
25
- {!Permissions}: Fine-grained permission system for tool usage
24
26
- {!Options}: Configuration options for Claude sessions
···
29
31
30
32
{[
31
33
open Claude
32
-
34
+
33
35
(* Create a simple query *)
34
36
let query_claude ~sw env prompt =
35
37
let options = Options.default in
36
38
Client.query ~sw env ~options prompt
37
-
39
+
38
40
(* Process streaming responses *)
39
41
let process_response messages =
40
-
Seq.iter (function
41
-
| Message.Assistant msg ->
42
-
List.iter (function
43
-
| Content_block.Text t ->
44
-
print_endline (Content_block.Text.text t)
45
-
| _ -> ()
46
-
) (Message.Assistant.content msg)
47
-
| _ -> ()
48
-
) messages
42
+
Seq.iter
43
+
(function
44
+
| Message.Assistant msg ->
45
+
List.iter
46
+
(function
47
+
| Content_block.Text t ->
48
+
print_endline (Content_block.Text.text t)
49
+
| _ -> ())
50
+
(Message.Assistant.content msg)
51
+
| _ -> ())
52
+
messages
49
53
]}
50
54
51
55
{1 Advanced Features}
···
55
59
Control which tools Claude can use and how:
56
60
57
61
{[
58
-
let options =
62
+
let options =
59
63
Options.default
60
-
|> Options.with_allowed_tools ["Read"; "Write"; "Bash"]
64
+
|> Options.with_allowed_tools [ "Read"; "Write"; "Bash" ]
61
65
|> Options.with_permission_mode Permissions.Mode.Accept_edits
62
66
]}
63
67
···
69
73
let my_callback ~tool_name ~input ~context =
70
74
if tool_name = "Bash" then
71
75
Permissions.Result.deny ~message:"Bash not allowed" ~interrupt:false
72
-
else
73
-
Permissions.Result.allow ()
74
-
75
-
let options = Options.default |> Options.with_permission_callback my_callback
76
+
else Permissions.Result.allow ()
77
+
78
+
let options =
79
+
Options.default |> Options.with_permission_callback my_callback
76
80
]}
77
81
78
82
{2 System Prompts}
···
80
84
Customize Claude's behavior with system prompts:
81
85
82
86
{[
83
-
let options =
87
+
let options =
84
88
Options.default
85
-
|> Options.with_system_prompt "You are a helpful OCaml programming assistant."
89
+
|> Options.with_system_prompt
90
+
"You are a helpful OCaml programming assistant."
86
91
|> Options.with_append_system_prompt "Always use Jane Street style."
87
92
]}
88
93
89
94
{1 Logging}
90
95
91
-
The library uses the Logs library for structured logging. Each module has its
92
-
own log source (e.g., "claude.message", "claude.transport") allowing fine-grained
93
-
control over logging verbosity:
96
+
The library uses the Logs library for structured logging. Each module has
97
+
its own log source (e.g., "claude.message", "claude.transport") allowing
98
+
fine-grained control over logging verbosity:
94
99
95
100
{[
96
101
(* Enable debug logging for message handling *)
97
102
Logs.Src.set_level Message.src (Some Logs.Debug);
98
-
103
+
99
104
(* Enable info logging for transport layer *)
100
-
Logs.Src.set_level Transport.src (Some Logs.Info);
105
+
Logs.Src.set_level Transport.src (Some Logs.Info)
101
106
]}
102
107
103
108
{1 Error Handling}
···
111
116
112
117
{[
113
118
let run_claude_session ~sw env =
114
-
let options =
115
-
Options.create
116
-
~allowed_tools:["Read"; "Write"]
119
+
let options =
120
+
Options.create ~allowed_tools:[ "Read"; "Write" ]
117
121
~permission_mode:Permissions.Mode.Accept_edits
118
-
~system_prompt:"You are an OCaml expert."
119
-
~max_thinking_tokens:10000
122
+
~system_prompt:"You are an OCaml expert." ~max_thinking_tokens:10000
120
123
()
121
124
in
122
-
125
+
123
126
let prompt = "Write a function to calculate fibonacci numbers" in
124
127
let messages = Client.query ~sw env ~options prompt in
125
-
126
-
Seq.iter (fun msg ->
127
-
Message.log_received msg;
128
-
match msg with
129
-
| Message.Assistant assistant ->
130
-
Printf.printf "Claude: %s\n"
131
-
(Message.Assistant.model assistant);
132
-
List.iter (function
133
-
| Content_block.Text t ->
134
-
print_endline (Content_block.Text.text t)
135
-
| Content_block.Tool_use t ->
136
-
Printf.printf "Using tool: %s\n"
137
-
(Content_block.Tool_use.name t)
138
-
| _ -> ()
139
-
) (Message.Assistant.content assistant)
140
-
| Message.Result result ->
141
-
Printf.printf "Session complete. Duration: %dms\n"
142
-
(Message.Result.duration_ms result)
143
-
| _ -> ()
144
-
) messages
145
-
]}
146
-
*)
128
+
129
+
Seq.iter
130
+
(fun msg ->
131
+
Message.log_received msg;
132
+
match msg with
133
+
| Message.Assistant assistant ->
134
+
Printf.printf "Claude: %s\n" (Message.Assistant.model assistant);
135
+
List.iter
136
+
(function
137
+
| Content_block.Text t ->
138
+
print_endline (Content_block.Text.text t)
139
+
| Content_block.Tool_use t ->
140
+
Printf.printf "Using tool: %s\n"
141
+
(Content_block.Tool_use.name t)
142
+
| _ -> ())
143
+
(Message.Assistant.content assistant)
144
+
| Message.Result result ->
145
+
Printf.printf "Session complete. Duration: %dms\n"
146
+
(Message.Result.duration_ms result)
147
+
| _ -> ())
148
+
messages
149
+
]} *)
147
150
148
151
(** {1 Modules} *)
149
152
+218
-177
lib/client.ml
+218
-177
lib/client.ml
···
1
1
let src = Logs.Src.create "claude.client" ~doc:"Claude client"
2
+
2
3
module Log = (val Logs.src_log src : Logs.LOG)
3
4
4
5
(** Control response builders using Sdk_control codecs *)
···
6
7
let success ~request_id ~response =
7
8
let resp = Sdk_control.Response.success ~request_id ?response () in
8
9
let ctrl = Sdk_control.create_response ~response:resp () in
9
-
match Jsont.Json.encode Sdk_control.jsont ctrl with
10
-
| Ok json -> json
11
-
| Error msg -> failwith ("Control_response.success: " ^ msg)
10
+
Jsont.Json.encode Sdk_control.jsont ctrl
11
+
|> Err.get_ok ~msg:"Control_response.success: "
12
12
13
13
let error ~request_id ~message =
14
14
let resp = Sdk_control.Response.error ~request_id ~error:message () in
15
15
let ctrl = Sdk_control.create_response ~response:resp () in
16
-
match Jsont.Json.encode Sdk_control.jsont ctrl with
17
-
| Ok json -> json
18
-
| Error msg -> failwith ("Control_response.error: " ^ msg)
16
+
Jsont.Json.encode Sdk_control.jsont ctrl
17
+
|> Err.get_ok ~msg:"Control_response.error: "
19
18
end
20
19
21
20
(* Helper functions for JSON manipulation using jsont *)
22
21
let json_to_string json =
23
-
match Jsont_bytesrw.encode_string' Jsont.json json with
24
-
| Ok s -> s
25
-
| Error err -> failwith (Jsont.Error.to_string err)
22
+
Jsont_bytesrw.encode_string' Jsont.json json
23
+
|> Result.map_error Jsont.Error.to_string
24
+
|> Err.get_ok ~msg:""
26
25
27
-
(** Wire-level codec for permission responses to CLI.
28
-
Uses camelCase field names as expected by the CLI protocol. *)
26
+
(** Wire-level codec for permission responses to CLI. Uses camelCase field names
27
+
as expected by the CLI protocol. *)
29
28
module Permission_wire = struct
30
29
type allow = { allow_behavior : string; allow_updated_input : Jsont.json }
31
30
type deny = { deny_behavior : string; deny_message : string }
32
31
33
32
let allow_jsont : allow Jsont.t =
34
-
let make allow_behavior allow_updated_input = { allow_behavior; allow_updated_input } in
33
+
let make allow_behavior allow_updated_input =
34
+
{ allow_behavior; allow_updated_input }
35
+
in
35
36
Jsont.Object.map ~kind:"AllowWire" make
36
37
|> Jsont.Object.mem "behavior" Jsont.string ~enc:(fun r -> r.allow_behavior)
37
-
|> Jsont.Object.mem "updatedInput" Jsont.json ~enc:(fun r -> r.allow_updated_input)
38
+
|> Jsont.Object.mem "updatedInput" Jsont.json ~enc:(fun r ->
39
+
r.allow_updated_input)
38
40
|> Jsont.Object.finish
39
41
40
42
let deny_jsont : deny Jsont.t =
···
45
47
|> Jsont.Object.finish
46
48
47
49
let encode_allow ~updated_input =
48
-
match Jsont.Json.encode allow_jsont { allow_behavior = "allow"; allow_updated_input = updated_input } with
49
-
| Ok json -> json
50
-
| Error msg -> failwith ("Permission_wire.encode_allow: " ^ msg)
50
+
Jsont.Json.encode allow_jsont
51
+
{ allow_behavior = "allow"; allow_updated_input = updated_input }
52
+
|> Err.get_ok ~msg:"Permission_wire.encode_allow: "
51
53
52
54
let encode_deny ~message =
53
-
match Jsont.Json.encode deny_jsont { deny_behavior = "deny"; deny_message = message } with
54
-
| Ok json -> json
55
-
| Error msg -> failwith ("Permission_wire.encode_deny: " ^ msg)
55
+
Jsont.Json.encode deny_jsont
56
+
{ deny_behavior = "deny"; deny_message = message }
57
+
|> Err.get_ok ~msg:"Permission_wire.encode_deny: "
56
58
end
57
59
58
60
(** Wire-level codec for hook matcher configuration sent to CLI. *)
59
61
module Hook_matcher_wire = struct
60
-
type t = {
61
-
matcher : string option;
62
-
hook_callback_ids : string list;
63
-
}
62
+
type t = { matcher : string option; hook_callback_ids : string list }
64
63
65
64
let jsont : t Jsont.t =
66
65
let make matcher hook_callback_ids = { matcher; hook_callback_ids } in
67
66
Jsont.Object.map ~kind:"HookMatcherWire" make
68
67
|> Jsont.Object.opt_mem "matcher" Jsont.string ~enc:(fun r -> r.matcher)
69
-
|> Jsont.Object.mem "hookCallbackIds" (Jsont.list Jsont.string) ~enc:(fun r -> r.hook_callback_ids)
68
+
|> Jsont.Object.mem "hookCallbackIds" (Jsont.list Jsont.string)
69
+
~enc:(fun r -> r.hook_callback_ids)
70
70
|> Jsont.Object.finish
71
71
72
72
let encode matchers =
73
-
Jsont.Json.list (List.map (fun m ->
74
-
match Jsont.Json.encode jsont m with
75
-
| Ok json -> json
76
-
| Error msg -> failwith ("Hook_matcher_wire.encode: " ^ msg)
77
-
) matchers)
73
+
List.map
74
+
(fun m ->
75
+
Jsont.Json.encode jsont m
76
+
|> Err.get_ok ~msg:"Hook_matcher_wire.encode: ")
77
+
matchers
78
+
|> Jsont.Json.list
78
79
end
79
80
80
81
type t = {
···
92
93
93
94
let handle_control_request t (ctrl_req : Incoming.Control_request.t) =
94
95
let request_id = Incoming.Control_request.request_id ctrl_req in
95
-
Log.info (fun m -> m "Handling control request: %s" (Incoming.Control_request.subtype ctrl_req));
96
+
Log.info (fun m ->
97
+
m "Handling control request: %s"
98
+
(Incoming.Control_request.subtype ctrl_req));
96
99
97
100
match Incoming.Control_request.request ctrl_req with
98
101
| Incoming.Control_request.Can_use_tool req ->
99
102
let tool_name = Incoming.Control_request.Can_use_tool.tool_name req in
100
103
let input = Incoming.Control_request.Can_use_tool.input req in
101
-
Log.info (fun m -> m "Permission request for tool '%s' with input: %s"
102
-
tool_name (json_to_string input));
104
+
Log.info (fun m ->
105
+
m "Permission request for tool '%s' with input: %s" tool_name
106
+
(json_to_string input));
103
107
(* TODO: Parse permission_suggestions properly *)
104
108
let context = Permissions.Context.create ~suggestions:[] () in
105
109
106
-
Log.info (fun m -> m "Invoking permission callback for tool: %s" tool_name);
107
-
let result = match t.permission_callback with
108
-
| Some callback ->
109
-
Log.info (fun m -> m "Using custom permission callback");
110
-
callback ~tool_name ~input ~context
111
-
| None ->
112
-
Log.info (fun m -> m "Using default allow callback");
113
-
Permissions.default_allow_callback ~tool_name ~input ~context
110
+
Log.info (fun m ->
111
+
m "Invoking permission callback for tool: %s" tool_name);
112
+
let callback =
113
+
Option.value t.permission_callback
114
+
~default:Permissions.default_allow_callback
114
115
in
115
-
Log.info (fun m -> m "Permission callback returned: %s"
116
-
(match result with
117
-
| Permissions.Result.Allow _ -> "ALLOW"
118
-
| Permissions.Result.Deny _ -> "DENY"));
116
+
let result = callback ~tool_name ~input ~context in
117
+
Log.info (fun m ->
118
+
m "Permission callback returned: %s"
119
+
(match result with
120
+
| Permissions.Result.Allow _ -> "ALLOW"
121
+
| Permissions.Result.Deny _ -> "DENY"));
119
122
120
123
(* Convert permission result to CLI format using wire codec *)
121
-
let response_data = match result with
122
-
| Permissions.Result.Allow { updated_input; updated_permissions = _; unknown = _ } ->
124
+
let response_data =
125
+
match result with
126
+
| Permissions.Result.Allow
127
+
{ updated_input; updated_permissions = _; unknown = _ } ->
123
128
let updated_input = Option.value updated_input ~default:input in
124
129
Permission_wire.encode_allow ~updated_input
125
130
| Permissions.Result.Deny { message; interrupt = _; unknown = _ } ->
126
131
Permission_wire.encode_deny ~message
127
132
in
128
-
let response = Control_response.success ~request_id ~response:(Some response_data) in
129
-
Log.info (fun m -> m "Sending control response: %s" (json_to_string response));
133
+
let response =
134
+
Control_response.success ~request_id ~response:(Some response_data)
135
+
in
136
+
Log.info (fun m ->
137
+
m "Sending control response: %s" (json_to_string response));
130
138
Transport.send t.transport response
131
-
132
-
| Incoming.Control_request.Hook_callback req ->
133
-
let callback_id = Incoming.Control_request.Hook_callback.callback_id req in
139
+
| Incoming.Control_request.Hook_callback req -> (
140
+
let callback_id =
141
+
Incoming.Control_request.Hook_callback.callback_id req
142
+
in
134
143
let input = Incoming.Control_request.Hook_callback.input req in
135
-
let tool_use_id = Incoming.Control_request.Hook_callback.tool_use_id req in
136
-
Log.info (fun m -> m "Hook callback request for callback_id: %s" callback_id);
144
+
let tool_use_id =
145
+
Incoming.Control_request.Hook_callback.tool_use_id req
146
+
in
147
+
Log.info (fun m ->
148
+
m "Hook callback request for callback_id: %s" callback_id);
137
149
138
-
(try
150
+
try
139
151
let callback = Hashtbl.find t.hook_callbacks callback_id in
140
152
let context = Hooks.Context.create () in
141
153
let result = callback ~input ~tool_use_id ~context in
142
154
143
-
let result_json = match Jsont.Json.encode Hooks.result_jsont result with
144
-
| Ok j -> j
145
-
| Error msg -> failwith ("Failed to encode hook result: " ^ msg)
155
+
let result_json =
156
+
Jsont.Json.encode Hooks.result_jsont result
157
+
|> Err.get_ok ~msg:"Failed to encode hook result: "
146
158
in
147
-
let response = Control_response.success ~request_id ~response:(Some result_json) in
159
+
let response =
160
+
Control_response.success ~request_id ~response:(Some result_json)
161
+
in
148
162
Log.info (fun m -> m "Hook callback succeeded, sending response");
149
163
Transport.send t.transport response
150
164
with
151
165
| Not_found ->
152
-
let error_msg = Printf.sprintf "Hook callback not found: %s" callback_id in
166
+
let error_msg =
167
+
Printf.sprintf "Hook callback not found: %s" callback_id
168
+
in
153
169
Log.err (fun m -> m "%s" error_msg);
154
-
Transport.send t.transport (Control_response.error ~request_id ~message:error_msg)
170
+
Transport.send t.transport
171
+
(Control_response.error ~request_id ~message:error_msg)
155
172
| exn ->
156
-
let error_msg = Printf.sprintf "Hook callback error: %s" (Printexc.to_string exn) in
173
+
let error_msg =
174
+
Printf.sprintf "Hook callback error: %s" (Printexc.to_string exn)
175
+
in
157
176
Log.err (fun m -> m "%s" error_msg);
158
-
Transport.send t.transport (Control_response.error ~request_id ~message:error_msg))
159
-
177
+
Transport.send t.transport
178
+
(Control_response.error ~request_id ~message:error_msg))
160
179
| Incoming.Control_request.Unknown (subtype, _) ->
161
-
let error_msg = Printf.sprintf "Unsupported control request: %s" subtype in
162
-
Transport.send t.transport (Control_response.error ~request_id ~message:error_msg)
180
+
let error_msg =
181
+
Printf.sprintf "Unsupported control request: %s" subtype
182
+
in
183
+
Transport.send t.transport
184
+
(Control_response.error ~request_id ~message:error_msg)
163
185
164
186
let handle_control_response t control_resp =
165
-
let request_id = match control_resp.Sdk_control.response with
187
+
let request_id =
188
+
match control_resp.Sdk_control.response with
166
189
| Sdk_control.Response.Success s -> s.request_id
167
190
| Sdk_control.Response.Error e -> e.request_id
168
191
in
169
-
Log.debug (fun m -> m "Received control response for request_id: %s" request_id);
192
+
Log.debug (fun m ->
193
+
m "Received control response for request_id: %s" request_id);
170
194
171
195
(* Store the response as JSON and signal waiting threads *)
172
-
let json = match Jsont.Json.encode Sdk_control.control_response_jsont control_resp with
173
-
| Ok j -> j
174
-
| Error err -> failwith ("Failed to encode control response: " ^ err)
196
+
let json =
197
+
Jsont.Json.encode Sdk_control.control_response_jsont control_resp
198
+
|> Err.get_ok ~msg:"Failed to encode control response: "
175
199
in
176
200
Eio.Mutex.use_rw ~protect:false t.control_mutex (fun () ->
177
-
Hashtbl.replace t.control_responses request_id json;
178
-
Eio.Condition.broadcast t.control_condition
179
-
)
201
+
Hashtbl.replace t.control_responses request_id json;
202
+
Eio.Condition.broadcast t.control_condition)
180
203
181
204
let handle_messages t =
182
205
let rec loop () =
···
185
208
(* EOF *)
186
209
Log.debug (fun m -> m "Handle messages: EOF received");
187
210
Seq.Nil
188
-
| Some line ->
211
+
| Some line -> (
189
212
(* Use unified Incoming codec for all message types *)
190
213
match Jsont_bytesrw.decode_string' Incoming.jsont line with
191
214
| Ok (Incoming.Message msg) ->
···
194
217
(* Extract session ID from system messages *)
195
218
(match msg with
196
219
| Message.System sys ->
197
-
(match Message.System.session_id sys with
198
-
| Some session_id ->
199
-
t.session_id <- Some session_id;
200
-
Log.debug (fun m -> m "Stored session ID: %s" session_id)
201
-
| None -> ())
220
+
Message.System.session_id sys
221
+
|> Option.iter (fun session_id ->
222
+
t.session_id <- Some session_id;
223
+
Log.debug (fun m -> m "Stored session ID: %s" session_id))
202
224
| _ -> ());
203
225
204
226
Seq.Cons (msg, loop)
205
-
206
227
| Ok (Incoming.Control_response resp) ->
207
228
handle_control_response t resp;
208
229
loop ()
209
-
210
230
| Ok (Incoming.Control_request ctrl_req) ->
211
-
Log.info (fun m -> m "Received control request: %s (request_id: %s)"
212
-
(Incoming.Control_request.subtype ctrl_req)
213
-
(Incoming.Control_request.request_id ctrl_req));
231
+
Log.info (fun m ->
232
+
m "Received control request: %s (request_id: %s)"
233
+
(Incoming.Control_request.subtype ctrl_req)
234
+
(Incoming.Control_request.request_id ctrl_req));
214
235
handle_control_request t ctrl_req;
215
236
loop ()
216
-
217
237
| Error err ->
218
-
Log.err (fun m -> m "Failed to decode incoming message: %s\nLine: %s"
219
-
(Jsont.Error.to_string err) line);
220
-
loop ()
238
+
Log.err (fun m ->
239
+
m "Failed to decode incoming message: %s\nLine: %s"
240
+
(Jsont.Error.to_string err)
241
+
line);
242
+
loop ())
221
243
in
222
244
Log.debug (fun m -> m "Starting message handler");
223
245
loop
···
238
260
let hook_callbacks = Hashtbl.create 16 in
239
261
let next_callback_id = ref 0 in
240
262
241
-
let t = {
242
-
transport;
243
-
permission_callback = Options.permission_callback options;
244
-
permission_log = None;
245
-
hook_callbacks;
246
-
session_id = None;
247
-
control_responses = Hashtbl.create 16;
248
-
control_mutex = Eio.Mutex.create ();
249
-
control_condition = Eio.Condition.create ();
250
-
} in
263
+
let t =
264
+
{
265
+
transport;
266
+
permission_callback = Options.permission_callback options;
267
+
permission_log = None;
268
+
hook_callbacks;
269
+
session_id = None;
270
+
control_responses = Hashtbl.create 16;
271
+
control_mutex = Eio.Mutex.create ();
272
+
control_condition = Eio.Condition.create ();
273
+
}
274
+
in
251
275
252
276
(* Register hooks and send initialize if hooks are configured *)
253
-
(match Options.hooks options with
254
-
| Some hooks_config ->
277
+
Options.hooks options
278
+
|> Option.iter (fun hooks_config ->
255
279
Log.info (fun m -> m "Registering hooks...");
256
280
257
281
(* Build hooks configuration with callback IDs as (string * Jsont.json) list *)
258
-
let hooks_list = List.map (fun (event, matchers) ->
259
-
let event_name = Hooks.event_to_string event in
260
-
let matcher_wires = List.map (fun matcher ->
261
-
let callback_ids = List.map (fun callback ->
262
-
let callback_id = Printf.sprintf "hook_%d" !next_callback_id in
263
-
incr next_callback_id;
264
-
Hashtbl.add hook_callbacks callback_id callback;
265
-
Log.debug (fun m -> m "Registered callback: %s for event: %s" callback_id event_name);
266
-
callback_id
267
-
) matcher.Hooks.callbacks in
268
-
Hook_matcher_wire.{ matcher = matcher.Hooks.matcher; hook_callback_ids = callback_ids }
269
-
) matchers in
270
-
(event_name, Hook_matcher_wire.encode matcher_wires)
271
-
) hooks_config in
282
+
let hooks_list =
283
+
List.map
284
+
(fun (event, matchers) ->
285
+
let event_name = Hooks.event_to_string event in
286
+
let matcher_wires =
287
+
List.map
288
+
(fun matcher ->
289
+
let callback_ids =
290
+
List.map
291
+
(fun callback ->
292
+
let callback_id =
293
+
Printf.sprintf "hook_%d" !next_callback_id
294
+
in
295
+
incr next_callback_id;
296
+
Hashtbl.add hook_callbacks callback_id callback;
297
+
Log.debug (fun m ->
298
+
m "Registered callback: %s for event: %s"
299
+
callback_id event_name);
300
+
callback_id)
301
+
matcher.Hooks.callbacks
302
+
in
303
+
Hook_matcher_wire.
304
+
{
305
+
matcher = matcher.Hooks.matcher;
306
+
hook_callback_ids = callback_ids;
307
+
})
308
+
matchers
309
+
in
310
+
(event_name, Hook_matcher_wire.encode matcher_wires))
311
+
hooks_config
312
+
in
272
313
273
314
(* Create initialize request using Sdk_control codec *)
274
315
let request = Sdk_control.Request.initialize ~hooks:hooks_list () in
275
-
let ctrl_req = Sdk_control.create_request ~request_id:"init_hooks" ~request () in
276
-
let initialize_msg = match Jsont.Json.encode Sdk_control.jsont ctrl_req with
277
-
| Ok json -> json
278
-
| Error msg -> failwith ("Failed to encode initialize request: " ^ msg)
316
+
let ctrl_req =
317
+
Sdk_control.create_request ~request_id:"init_hooks" ~request ()
318
+
in
319
+
let initialize_msg =
320
+
Jsont.Json.encode Sdk_control.jsont ctrl_req
321
+
|> Err.get_ok ~msg:"Failed to encode initialize request: "
279
322
in
280
323
Log.info (fun m -> m "Sending hooks initialize request");
281
-
Transport.send t.transport initialize_msg
282
-
| None -> ());
324
+
Transport.send t.transport initialize_msg);
283
325
284
326
t
285
327
···
300
342
let json = Message.User.to_json user_msg in
301
343
Transport.send t.transport json
302
344
303
-
let receive t =
304
-
handle_messages t
345
+
let receive t = handle_messages t
305
346
306
347
let receive_all t =
307
348
let rec collect acc seq =
308
349
match seq () with
309
-
| Seq.Nil ->
310
-
Log.debug (fun m -> m "End of message sequence (%d messages)" (List.length acc));
350
+
| Seq.Nil ->
351
+
Log.debug (fun m ->
352
+
m "End of message sequence (%d messages)" (List.length acc));
311
353
List.rev acc
312
-
| Seq.Cons (Message.Result _ as msg, _) ->
354
+
| Seq.Cons ((Message.Result _ as msg), _) ->
313
355
Log.debug (fun m -> m "Received final Result message");
314
356
List.rev (msg :: acc)
315
-
| Seq.Cons (msg, rest) ->
316
-
collect (msg :: acc) rest
357
+
| Seq.Cons (msg, rest) -> collect (msg :: acc) rest
317
358
in
318
359
collect [] (handle_messages t)
319
360
320
-
let interrupt t =
321
-
Transport.interrupt t.transport
361
+
let interrupt t = Transport.interrupt t.transport
322
362
323
363
let discover_permissions t =
324
364
let log = ref [] in
325
365
let callback = Permissions.discovery_callback log in
326
-
{ t with
327
-
permission_callback = Some callback;
328
-
permission_log = Some log
329
-
}
366
+
{ t with permission_callback = Some callback; permission_log = Some log }
330
367
331
368
let get_discovered_permissions t =
332
-
match t.permission_log with
333
-
| Some log -> !log
334
-
| None -> []
369
+
t.permission_log |> Option.map ( ! ) |> Option.value ~default:[]
335
370
336
371
let with_permission_callback t callback =
337
372
{ t with permission_callback = Some callback }
···
340
375
let send_control_request t ~request_id request =
341
376
(* Send the control request *)
342
377
let control_msg = Sdk_control.create_request ~request_id ~request () in
343
-
let json = match Jsont.Json.encode Sdk_control.jsont control_msg with
344
-
| Ok j -> j
345
-
| Error msg -> failwith ("Failed to encode control request: " ^ msg)
378
+
let json =
379
+
Jsont.Json.encode Sdk_control.jsont control_msg
380
+
|> Err.get_ok ~msg:"Failed to encode control request: "
346
381
in
347
382
Log.info (fun m -> m "Sending control request: %s" (json_to_string json));
348
383
Transport.send t.transport json;
349
384
350
385
(* Wait for the response with timeout *)
351
-
let max_wait = 10.0 in (* 10 seconds timeout *)
386
+
let max_wait = 10.0 in
387
+
(* 10 seconds timeout *)
352
388
let start_time = Unix.gettimeofday () in
353
389
354
390
let rec wait_for_response () =
355
391
Eio.Mutex.use_rw ~protect:false t.control_mutex (fun () ->
356
-
match Hashtbl.find_opt t.control_responses request_id with
357
-
| Some response_json ->
358
-
(* Remove it from the table *)
359
-
Hashtbl.remove t.control_responses request_id;
360
-
response_json
361
-
| None ->
362
-
let elapsed = Unix.gettimeofday () -. start_time in
363
-
if elapsed > max_wait then
364
-
raise (Failure (Printf.sprintf "Timeout waiting for control response: %s" request_id))
365
-
else (
366
-
(* Release mutex and wait for signal *)
367
-
Eio.Condition.await_no_mutex t.control_condition;
368
-
wait_for_response ()
369
-
)
370
-
)
392
+
match Hashtbl.find_opt t.control_responses request_id with
393
+
| Some response_json ->
394
+
(* Remove it from the table *)
395
+
Hashtbl.remove t.control_responses request_id;
396
+
response_json
397
+
| None ->
398
+
let elapsed = Unix.gettimeofday () -. start_time in
399
+
if elapsed > max_wait then
400
+
raise
401
+
(Failure
402
+
(Printf.sprintf "Timeout waiting for control response: %s"
403
+
request_id))
404
+
else (
405
+
(* Release mutex and wait for signal *)
406
+
Eio.Condition.await_no_mutex t.control_condition;
407
+
wait_for_response ()))
371
408
in
372
409
373
410
let response_json = wait_for_response () in
374
-
Log.debug (fun m -> m "Received control response: %s" (json_to_string response_json));
411
+
Log.debug (fun m ->
412
+
m "Received control response: %s" (json_to_string response_json));
375
413
376
414
(* Parse the response - extract the "response" field using jsont codec *)
377
-
let response_field_codec = Jsont.Object.map ~kind:"ResponseField" Fun.id
415
+
let response_field_codec =
416
+
Jsont.Object.map ~kind:"ResponseField" Fun.id
378
417
|> Jsont.Object.mem "response" Jsont.json ~enc:Fun.id
379
418
|> Jsont.Object.finish
380
419
in
381
-
let response_data = match Jsont.Json.decode response_field_codec response_json with
382
-
| Ok r -> r
383
-
| Error msg -> raise (Invalid_argument ("Failed to extract response field: " ^ msg))
420
+
let response_data =
421
+
Jsont.Json.decode response_field_codec response_json
422
+
|> Err.get_ok' ~msg:"Failed to extract response field: "
384
423
in
385
-
let response = match Jsont.Json.decode Sdk_control.Response.jsont response_data with
386
-
| Ok r -> r
387
-
| Error msg -> raise (Invalid_argument ("Failed to decode response: " ^ msg))
424
+
let response =
425
+
Jsont.Json.decode Sdk_control.Response.jsont response_data
426
+
|> Err.get_ok' ~msg:"Failed to decode response: "
388
427
in
389
428
match response with
390
429
| Sdk_control.Response.Success s -> s.response
···
395
434
let request_id = Printf.sprintf "set_perm_mode_%f" (Unix.gettimeofday ()) in
396
435
let request = Sdk_control.Request.set_permission_mode ~mode () in
397
436
let _response = send_control_request t ~request_id request in
398
-
Log.info (fun m -> m "Permission mode set to: %s" (Permissions.Mode.to_string mode))
437
+
Log.info (fun m ->
438
+
m "Permission mode set to: %s" (Permissions.Mode.to_string mode))
399
439
400
440
let set_model t model =
401
441
let model_str = Model.to_string model in
···
403
443
let request = Sdk_control.Request.set_model ~model:model_str () in
404
444
let _response = send_control_request t ~request_id request in
405
445
Log.info (fun m -> m "Model set to: %s" model_str)
406
-
407
-
let set_model_string t model_str =
408
-
set_model t (Model.of_string model_str)
409
446
410
447
let get_server_info t =
411
448
let request_id = Printf.sprintf "get_server_info_%f" (Unix.gettimeofday ()) in
412
449
let request = Sdk_control.Request.get_server_info () in
413
-
match send_control_request t ~request_id request with
414
-
| Some response_data ->
415
-
let server_info = match Jsont.Json.decode Sdk_control.Server_info.jsont response_data with
416
-
| Ok si -> si
417
-
| Error msg -> raise (Invalid_argument ("Failed to decode server info: " ^ msg))
418
-
in
419
-
Log.info (fun m -> m "Retrieved server info: %a" (Jsont.pp_value Sdk_control.Server_info.jsont ()) server_info);
420
-
server_info
421
-
| None ->
422
-
raise (Failure "No response data from get_server_info request")
450
+
let response_data =
451
+
send_control_request t ~request_id request
452
+
|> Option.to_result ~none:"No response data from get_server_info request"
453
+
|> Err.get_ok ~msg:""
454
+
in
455
+
let server_info =
456
+
Jsont.Json.decode Sdk_control.Server_info.jsont response_data
457
+
|> Err.get_ok' ~msg:"Failed to decode server info: "
458
+
in
459
+
Log.info (fun m ->
460
+
m "Retrieved server info: %a"
461
+
(Jsont.pp_value Sdk_control.Server_info.jsont ())
462
+
server_info);
463
+
server_info
+31
-35
lib/client.mli
+31
-35
lib/client.mli
···
8
8
9
9
{[
10
10
Eio.Switch.run @@ fun sw ->
11
-
let client = Client.create ~sw ~process_mgr () in
12
-
Client.query client "What is 2+2?";
11
+
let client = Client.create ~sw ~process_mgr () in
12
+
Client.query client "What is 2+2?";
13
13
14
-
let messages = Client.receive_all client in
15
-
List.iter (function
14
+
let messages = Client.receive_all client in
15
+
List.iter
16
+
(function
16
17
| Message.Assistant msg ->
17
18
Printf.printf "Claude: %s\n" (Message.Assistant.text msg)
18
-
| _ -> ()
19
-
) messages
19
+
| _ -> ())
20
+
messages
20
21
]}
21
22
22
23
{2 Features}
···
29
30
30
31
{2 Message Flow}
31
32
32
-
1. Create a client with {!create}
33
-
2. Send messages with {!query} or {!send_message}
34
-
3. Receive responses with {!receive} or {!receive_all}
35
-
4. Continue multi-turn conversations by sending more messages
36
-
5. Client automatically cleans up when the switch exits
33
+
1. Create a client with {!create} 2. Send messages with {!query} or
34
+
{!send_message} 3. Receive responses with {!receive} or {!receive_all} 4.
35
+
Continue multi-turn conversations by sending more messages 5. Client
36
+
automatically cleans up when the switch exits
37
37
38
38
{2 Advanced Features}
39
39
···
41
41
- Mid-conversation model switching and permission mode changes
42
42
- Server capability introspection *)
43
43
44
-
(** The log source for client operations *)
45
44
val src : Logs.Src.t
45
+
(** The log source for client operations *)
46
46
47
47
type t
48
48
(** The type of Claude clients. *)
···
56
56
?options:Options.t ->
57
57
sw:Eio.Switch.t ->
58
58
process_mgr:_ Eio.Process.mgr ->
59
-
unit -> t
59
+
unit ->
60
+
t
60
61
(** [create ?options ~sw ~process_mgr ()] creates a new Claude client.
61
62
62
63
@param options Configuration options (defaults to {!Options.default})
···
66
67
val query : t -> string -> unit
67
68
(** [query t prompt] sends a text message to Claude.
68
69
69
-
This is a convenience function for simple string messages. For more
70
-
complex messages with tool results or multiple content blocks, use
71
-
{!send_message} instead. *)
70
+
This is a convenience function for simple string messages. For more complex
71
+
messages with tool results or multiple content blocks, use {!send_message}
72
+
instead. *)
72
73
73
74
val send_message : t -> Message.t -> unit
74
75
(** [send_message t msg] sends a message to Claude.
···
92
93
val receive_all : t -> Message.t list
93
94
(** [receive_all t] collects all messages into a list.
94
95
95
-
This is a convenience function that consumes the {!receive} sequence.
96
-
Use this when you want to process all messages at once rather than
97
-
streaming them. *)
96
+
This is a convenience function that consumes the {!receive} sequence. Use
97
+
this when you want to process all messages at once rather than streaming
98
+
them. *)
98
99
99
100
val interrupt : t -> unit
100
101
(** [interrupt t] sends an interrupt signal to stop Claude's execution. *)
···
103
104
(** [discover_permissions t] enables permission discovery mode.
104
105
105
106
In discovery mode, all tool usage is logged but allowed. Use
106
-
{!get_discovered_permissions} to retrieve the list of permissions
107
-
that were requested during execution.
107
+
{!get_discovered_permissions} to retrieve the list of permissions that were
108
+
requested during execution.
108
109
109
110
This is useful for understanding what permissions your prompt requires. *)
110
111
111
112
val get_discovered_permissions : t -> Permissions.Rule.t list
112
-
(** [get_discovered_permissions t] returns permissions discovered during execution.
113
+
(** [get_discovered_permissions t] returns permissions discovered during
114
+
execution.
113
115
114
116
Only useful after enabling {!discover_permissions}. *)
115
117
116
118
val with_permission_callback : t -> Permissions.callback -> t
117
119
(** [with_permission_callback t callback] updates the permission callback.
118
120
119
-
Allows dynamically changing the permission callback without recreating
120
-
the client. *)
121
+
Allows dynamically changing the permission callback without recreating the
122
+
client. *)
121
123
122
124
(** {1 Dynamic Control Methods}
123
125
124
-
These methods allow you to change Claude's behavior mid-conversation
125
-
without recreating the client. This is useful for:
126
+
These methods allow you to change Claude's behavior mid-conversation without
127
+
recreating the client. This is useful for:
126
128
127
129
- Adjusting permission strictness based on user feedback
128
130
- Switching to faster/cheaper models for simple tasks
···
173
175
Printf.printf "Claude CLI version: %s\n"
174
176
(Sdk_control.Server_info.version info);
175
177
Printf.printf "Capabilities: %s\n"
176
-
(String.concat ", " (Sdk_control.Server_info.capabilities info));
178
+
(String.concat ", " (Sdk_control.Server_info.capabilities info))
177
179
]} *)
178
180
179
181
val set_permission_mode : t -> Permissions.Mode.t -> unit
180
182
(** [set_permission_mode t mode] changes the permission mode mid-conversation.
181
183
182
-
This allows switching between permission modes without recreating the client:
184
+
This allows switching between permission modes without recreating the
185
+
client:
183
186
- {!Permissions.Mode.Default} - Prompt for all permissions
184
187
- {!Permissions.Mode.Accept_edits} - Auto-accept file edits
185
188
- {!Permissions.Mode.Plan} - Planning mode with restricted execution
···
194
197
- [`Sonnet_4_5] - Most capable, balanced performance
195
198
- [`Opus_4] - Maximum capability for complex tasks
196
199
- [`Haiku_4] - Fast and cost-effective
197
-
198
-
@raise Failure if the model is invalid or unavailable *)
199
-
200
-
val set_model_string : t -> string -> unit
201
-
(** [set_model_string t model] switches to a different AI model using a string.
202
-
203
-
This is a convenience function that parses the string using {!Model.of_string}.
204
200
205
201
@raise Failure if the model is invalid or unavailable *)
206
202
+42
-40
lib/content_block.ml
+42
-40
lib/content_block.ml
···
1
1
let src = Logs.Src.create "claude.content_block" ~doc:"Claude content blocks"
2
-
module Log = (val Logs.src_log src : Logs.LOG)
3
2
3
+
module Log = (val Logs.src_log src : Logs.LOG)
4
4
5
5
module Text = struct
6
-
type t = {
7
-
text : string;
8
-
unknown : Unknown.t;
9
-
}
6
+
type t = { text : string; unknown : Unknown.t }
10
7
11
8
let create text = { text; unknown = Unknown.empty }
12
-
13
9
let make text unknown = { text; unknown }
14
10
let text t = t.text
15
11
let unknown t = t.unknown
···
29
25
let jsont = Jsont.json
30
26
31
27
let of_string_pairs pairs =
32
-
Jsont.Json.object' (List.map (fun (k, v) ->
33
-
Jsont.Json.mem (Jsont.Json.name k) (Jsont.Json.string v)
34
-
) pairs)
28
+
Jsont.Json.object'
29
+
(List.map
30
+
(fun (k, v) ->
31
+
Jsont.Json.mem (Jsont.Json.name k) (Jsont.Json.string v))
32
+
pairs)
35
33
36
34
let of_assoc (assoc : (string * Jsont.json) list) : t =
37
-
Jsont.Json.object' (List.map (fun (k, v) -> Jsont.Json.mem (Jsont.Json.name k) v) assoc)
35
+
Jsont.Json.object'
36
+
(List.map (fun (k, v) -> Jsont.Json.mem (Jsont.Json.name k) v) assoc)
38
37
39
38
(* Helper to decode an optional field with a given codec *)
40
39
let get_opt (type a) (codec : a Jsont.t) t key : a option =
41
-
let field_codec = Jsont.Object.map ~kind:"field" (fun v -> v)
40
+
let field_codec =
41
+
Jsont.Object.map ~kind:"field" (fun v -> v)
42
42
|> Jsont.Object.opt_mem key codec ~enc:Fun.id
43
43
|> Jsont.Object.finish
44
44
in
45
-
match Jsont.Json.decode field_codec t with
46
-
| Ok v -> v
47
-
| Error _ -> None
45
+
match Jsont.Json.decode field_codec t with Ok v -> v | Error _ -> None
48
46
49
47
let get_string t key = get_opt Jsont.string t key
50
48
let get_int t key = get_opt Jsont.int t key
···
54
52
let keys t =
55
53
(* Decode as object with all members captured as unknown *)
56
54
match t with
57
-
| Jsont.Object (members, _) -> List.map (fun ((name, _), _) -> name) members
55
+
| Jsont.Object (members, _) ->
56
+
List.map (fun ((name, _), _) -> name) members
58
57
| _ -> []
59
-
60
58
end
61
59
62
-
type t = {
63
-
id : string;
64
-
name : string;
65
-
input : Input.t;
66
-
unknown : Unknown.t;
67
-
}
60
+
type t = { id : string; name : string; input : Input.t; unknown : Unknown.t }
68
61
69
62
let create ~id ~name ~input = { id; name; input; unknown = Unknown.empty }
70
-
71
63
let make id name input unknown = { id; name; input; unknown }
72
64
let id t = t.id
73
65
let name t = t.name
···
96
88
97
89
let make tool_use_id content is_error unknown =
98
90
{ tool_use_id; content; is_error; unknown }
91
+
99
92
let tool_use_id t = t.tool_use_id
100
93
let content t = t.content
101
94
let is_error t = t.is_error
···
111
104
end
112
105
113
106
module Thinking = struct
114
-
type t = {
115
-
thinking : string;
116
-
signature : string;
117
-
unknown : Unknown.t;
118
-
}
107
+
type t = { thinking : string; signature : string; unknown : Unknown.t }
119
108
120
-
let create ~thinking ~signature = { thinking; signature; unknown = Unknown.empty }
109
+
let create ~thinking ~signature =
110
+
{ thinking; signature; unknown = Unknown.empty }
121
111
122
112
let make thinking signature unknown = { thinking; signature; unknown }
123
113
let thinking t = t.thinking
···
140
130
141
131
let text s = Text (Text.create s)
142
132
let tool_use ~id ~name ~input = Tool_use (Tool_use.create ~id ~name ~input)
133
+
143
134
let tool_result ~tool_use_id ?content ?is_error () =
144
135
Tool_result (Tool_result.create ~tool_use_id ?content ?is_error ())
136
+
145
137
let thinking ~thinking ~signature =
146
138
Thinking (Thinking.create ~thinking ~signature)
147
139
···
149
141
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
150
142
151
143
let case_text = case_map "text" Text.jsont (fun v -> Text v) in
152
-
let case_tool_use = case_map "tool_use" Tool_use.jsont (fun v -> Tool_use v) in
153
-
let case_tool_result = case_map "tool_result" Tool_result.jsont (fun v -> Tool_result v) in
154
-
let case_thinking = case_map "thinking" Thinking.jsont (fun v -> Thinking v) in
144
+
let case_tool_use =
145
+
case_map "tool_use" Tool_use.jsont (fun v -> Tool_use v)
146
+
in
147
+
let case_tool_result =
148
+
case_map "tool_result" Tool_result.jsont (fun v -> Tool_result v)
149
+
in
150
+
let case_thinking =
151
+
case_map "thinking" Thinking.jsont (fun v -> Thinking v)
152
+
in
155
153
156
154
let enc_case = function
157
155
| Text v -> Jsont.Object.Case.value case_text v
···
160
158
| Thinking v -> Jsont.Object.Case.value case_thinking v
161
159
in
162
160
163
-
let cases = Jsont.Object.Case.[
164
-
make case_text;
165
-
make case_tool_use;
166
-
make case_tool_result;
167
-
make case_thinking
168
-
] in
161
+
let cases =
162
+
Jsont.Object.Case.
163
+
[
164
+
make case_text;
165
+
make case_tool_use;
166
+
make case_tool_result;
167
+
make case_thinking;
168
+
]
169
+
in
169
170
170
171
Jsont.Object.map ~kind:"Content_block" Fun.id
171
172
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
172
-
~tag_to_string:Fun.id ~tag_compare:String.compare
173
+
~tag_to_string:Fun.id ~tag_compare:String.compare
173
174
|> Jsont.Object.finish
174
175
175
176
let log_received t =
176
-
Log.debug (fun m -> m "Received content block: %a" (Jsont.pp_value jsont ()) t)
177
+
Log.debug (fun m ->
178
+
m "Received content block: %a" (Jsont.pp_value jsont ()) t)
177
179
178
180
let log_sending t =
179
181
Log.debug (fun m -> m "Sending content block: %a" (Jsont.pp_value jsont ()) t)
+28
-22
lib/content_block.mli
+28
-22
lib/content_block.mli
···
1
1
(** Content blocks for Claude messages.
2
2
3
-
This module defines the various types of content blocks that can appear
4
-
in Claude messages, including text, tool use, tool results, and thinking blocks. *)
3
+
This module defines the various types of content blocks that can appear in
4
+
Claude messages, including text, tool use, tool results, and thinking
5
+
blocks. *)
5
6
7
+
val src : Logs.Src.t
6
8
(** The log source for content block operations *)
7
-
val src : Logs.Src.t
8
9
9
10
(** {1 Text Blocks} *)
10
11
···
24
25
(** [unknown t] returns any unknown fields from JSON parsing. *)
25
26
26
27
val jsont : t Jsont.t
27
-
(** [jsont] is the Jsont codec for text blocks.
28
-
Use [Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
29
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
28
+
(** [jsont] is the Jsont codec for text blocks. Use [Jsont.Json.encode jsont]
29
+
and [Jsont.Json.decode jsont] for serialization. Use
30
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
30
31
end
31
32
32
33
(** {1 Tool Use Blocks} *)
···
44
45
(** [jsont] is the Jsont codec for tool inputs. *)
45
46
46
47
val of_string_pairs : (string * string) list -> t
47
-
(** [of_string_pairs pairs] creates tool input from string key-value pairs. *)
48
+
(** [of_string_pairs pairs] creates tool input from string key-value pairs.
49
+
*)
48
50
49
51
val of_assoc : (string * Jsont.json) list -> t
50
52
(** [of_assoc assoc] creates tool input from an association list. *)
···
63
65
64
66
val keys : t -> string list
65
67
(** [keys t] returns all keys in the input. *)
66
-
67
68
end
68
69
69
70
type t
···
88
89
(** [unknown t] returns any unknown fields from JSON parsing. *)
89
90
90
91
val jsont : t Jsont.t
91
-
(** [jsont] is the Jsont codec for tool use blocks.
92
-
Use [Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
92
+
(** [jsont] is the Jsont codec for tool use blocks. Use
93
+
[Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
93
94
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
94
95
end
95
96
···
101
102
type t
102
103
(** The type of tool result blocks. *)
103
104
104
-
val create : tool_use_id:string -> ?content:string -> ?is_error:bool -> unit -> t
105
-
(** [create ~tool_use_id ?content ?is_error ()] creates a new tool result block.
105
+
val create :
106
+
tool_use_id:string -> ?content:string -> ?is_error:bool -> unit -> t
107
+
(** [create ~tool_use_id ?content ?is_error ()] creates a new tool result
108
+
block.
106
109
@param tool_use_id The ID of the corresponding tool use block
107
110
@param content Optional result content
108
111
@param is_error Whether the tool execution resulted in an error *)
···
120
123
(** [unknown t] returns any unknown fields from JSON parsing. *)
121
124
122
125
val jsont : t Jsont.t
123
-
(** [jsont] is the Jsont codec for tool result blocks.
124
-
Use [Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
126
+
(** [jsont] is the Jsont codec for tool result blocks. Use
127
+
[Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
125
128
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
126
129
end
127
130
···
148
151
(** [unknown t] returns any unknown fields from JSON parsing. *)
149
152
150
153
val jsont : t Jsont.t
151
-
(** [jsont] is the Jsont codec for thinking blocks.
152
-
Use [Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
154
+
(** [jsont] is the Jsont codec for thinking blocks. Use
155
+
[Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
153
156
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
154
157
end
155
158
···
160
163
| Tool_use of Tool_use.t
161
164
| Tool_result of Tool_result.t
162
165
| Thinking of Thinking.t
163
-
(** The type of content blocks, which can be text, tool use, tool result, or thinking. *)
166
+
(** The type of content blocks, which can be text, tool use, tool result,
167
+
or thinking. *)
164
168
165
169
val text : string -> t
166
170
(** [text s] creates a text content block. *)
···
168
172
val tool_use : id:string -> name:string -> input:Tool_use.Input.t -> t
169
173
(** [tool_use ~id ~name ~input] creates a tool use content block. *)
170
174
171
-
val tool_result : tool_use_id:string -> ?content:string -> ?is_error:bool -> unit -> t
172
-
(** [tool_result ~tool_use_id ?content ?is_error ()] creates a tool result content block. *)
175
+
val tool_result :
176
+
tool_use_id:string -> ?content:string -> ?is_error:bool -> unit -> t
177
+
(** [tool_result ~tool_use_id ?content ?is_error ()] creates a tool result
178
+
content block. *)
173
179
174
180
val thinking : thinking:string -> signature:string -> t
175
181
(** [thinking ~thinking ~signature] creates a thinking content block. *)
176
182
177
183
val jsont : t Jsont.t
178
-
(** [jsont] is the Jsont codec for content blocks.
179
-
Use [Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
180
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
184
+
(** [jsont] is the Jsont codec for content blocks. Use [Jsont.Json.encode jsont]
185
+
and [Jsont.Json.decode jsont] for serialization. Use
186
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
181
187
182
188
(** {1 Logging} *)
183
189
+16
-16
lib/control.ml
+16
-16
lib/control.ml
···
1
1
let src = Logs.Src.create "claude.control" ~doc:"Claude control messages"
2
+
2
3
module Log = (val Logs.src_log src : Logs.LOG)
3
4
4
5
type t = {
···
9
10
}
10
11
11
12
let jsont =
12
-
Jsont.Object.map ~kind:"Control"
13
-
(fun request_id subtype data unknown -> {request_id; subtype; data; unknown})
13
+
Jsont.Object.map ~kind:"Control" (fun request_id subtype data unknown ->
14
+
{ request_id; subtype; data; unknown })
14
15
|> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun t -> t.request_id)
15
16
|> Jsont.Object.mem "subtype" Jsont.string ~enc:(fun t -> t.subtype)
16
17
|> Jsont.Object.mem "data" Jsont.json ~enc:(fun t -> t.data)
···
25
26
let data t = t.data
26
27
27
28
let to_json t =
28
-
match Jsont_bytesrw.encode_string ~format:Jsont.Minify jsont t with
29
-
| Ok s ->
30
-
(match Jsont_bytesrw.decode_string' Jsont.json s with
31
-
| Ok json -> json
32
-
| Error e -> failwith (Jsont.Error.to_string e))
33
-
| Error e -> failwith e
29
+
Jsont_bytesrw.encode_string ~format:Jsont.Minify jsont t
30
+
|> Err.get_ok ~msg:"Control.to_json: "
31
+
|> Jsont_bytesrw.decode_string' Jsont.json
32
+
|> Result.map_error Jsont.Error.to_string
33
+
|> Err.get_ok ~msg:"Control.to_json: "
34
34
35
35
let of_json json =
36
-
match Jsont_bytesrw.encode_string ~format:Jsont.Minify Jsont.json json with
37
-
| Ok s ->
38
-
(match Jsont_bytesrw.decode_string jsont s with
39
-
| Ok t -> t
40
-
| Error e -> raise (Invalid_argument ("Control.of_json: " ^ e)))
41
-
| Error e -> raise (Invalid_argument ("Control.of_json: " ^ e))
36
+
Jsont_bytesrw.encode_string ~format:Jsont.Minify Jsont.json json
37
+
|> Err.get_ok' ~msg:"Control.of_json: "
38
+
|> Jsont_bytesrw.decode_string jsont
39
+
|> Err.get_ok' ~msg:"Control.of_json: "
42
40
43
41
let log_received t =
44
-
Log.debug (fun m -> m "Received control message: %a" (Jsont.pp_value jsont ()) t)
42
+
Log.debug (fun m ->
43
+
m "Received control message: %a" (Jsont.pp_value jsont ()) t)
45
44
46
45
let log_sending t =
47
-
Log.debug (fun m -> m "Sending control message: %a" (Jsont.pp_value jsont ()) t)
46
+
Log.debug (fun m ->
47
+
m "Sending control message: %a" (Jsont.pp_value jsont ()) t)
+2
-2
lib/control.mli
+2
-2
lib/control.mli
···
4
4
including session control, cancellation requests, and other operational
5
5
commands. *)
6
6
7
-
(** The log source for control message operations *)
8
7
val src : Logs.Src.t
8
+
(** The log source for control message operations *)
9
9
10
10
type t
11
11
(** The type of control messages. *)
···
41
41
(** [log_received t] logs that a control message was received. *)
42
42
43
43
val log_sending : t -> unit
44
-
(** [log_sending t] logs that a control message is being sent. *)
44
+
(** [log_sending t] logs that a control message is being sent. *)
+1
-1
lib/dune
+1
-1
lib/dune
+136
-101
lib/hooks.ml
+136
-101
lib/hooks.ml
···
1
1
let src = Logs.Src.create "claude.hooks" ~doc:"Claude hooks system"
2
+
2
3
module Log = (val Logs.src_log src : Logs.LOG)
3
4
4
5
(** Hook events that can be intercepted *)
···
28
29
| s -> raise (Invalid_argument (Printf.sprintf "Unknown hook event: %s" s))
29
30
30
31
let event_jsont : event Jsont.t =
31
-
Jsont.enum [
32
-
"PreToolUse", Pre_tool_use;
33
-
"PostToolUse", Post_tool_use;
34
-
"UserPromptSubmit", User_prompt_submit;
35
-
"Stop", Stop;
36
-
"SubagentStop", Subagent_stop;
37
-
"PreCompact", Pre_compact;
38
-
]
32
+
Jsont.enum
33
+
[
34
+
("PreToolUse", Pre_tool_use);
35
+
("PostToolUse", Post_tool_use);
36
+
("UserPromptSubmit", User_prompt_submit);
37
+
("Stop", Stop);
38
+
("SubagentStop", Subagent_stop);
39
+
("PreCompact", Pre_compact);
40
+
]
39
41
40
42
(** Context provided to hook callbacks *)
41
43
module Context = struct
42
44
type t = {
43
-
signal: unit option; (* Future: abort signal support *)
45
+
signal : unit option; (* Future: abort signal support *)
44
46
unknown : Unknown.t;
45
47
}
46
48
47
-
let create ?(signal = None) ?(unknown = Unknown.empty) () = { signal; unknown }
49
+
let create ?(signal = None) ?(unknown = Unknown.empty) () =
50
+
{ signal; unknown }
48
51
49
52
let signal t = t.signal
50
53
let unknown t = t.unknown
···
57
60
end
58
61
59
62
(** Hook decision control *)
60
-
type decision =
61
-
| Continue
62
-
| Block
63
+
type decision = Continue | Block
63
64
64
65
let decision_jsont : decision Jsont.t =
65
-
Jsont.enum [
66
-
"continue", Continue;
67
-
"block", Block;
68
-
]
66
+
Jsont.enum [ ("continue", Continue); ("block", Block) ]
69
67
70
-
(** Generic hook result *)
71
68
type result = {
72
-
decision: decision option;
73
-
system_message: string option;
74
-
hook_specific_output: Jsont.json option;
69
+
decision : decision option;
70
+
system_message : string option;
71
+
hook_specific_output : Jsont.json option;
75
72
unknown : Unknown.t;
76
73
}
74
+
(** Generic hook result *)
77
75
78
76
let result_jsont : result Jsont.t =
79
77
let make decision system_message hook_specific_output unknown =
···
81
79
in
82
80
Jsont.Object.map ~kind:"Result" make
83
81
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun r -> r.decision)
84
-
|> Jsont.Object.opt_mem "systemMessage" Jsont.string ~enc:(fun r -> r.system_message)
85
-
|> Jsont.Object.opt_mem "hookSpecificOutput" Jsont.json ~enc:(fun r -> r.hook_specific_output)
82
+
|> Jsont.Object.opt_mem "systemMessage" Jsont.string ~enc:(fun r ->
83
+
r.system_message)
84
+
|> Jsont.Object.opt_mem "hookSpecificOutput" Jsont.json ~enc:(fun r ->
85
+
r.hook_specific_output)
86
86
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
87
87
|> Jsont.Object.finish
88
88
89
89
(** {1 PreToolUse Hook} *)
90
90
module PreToolUse = struct
91
91
type input = {
92
-
session_id: string;
93
-
transcript_path: string;
94
-
tool_name: string;
95
-
tool_input: Jsont.json;
92
+
session_id : string;
93
+
transcript_path : string;
94
+
tool_name : string;
95
+
tool_input : Jsont.json;
96
96
unknown : Unknown.t;
97
97
}
98
98
···
124
124
type permission_decision = [ `Allow | `Deny | `Ask ]
125
125
126
126
let permission_decision_jsont : permission_decision Jsont.t =
127
-
Jsont.enum [
128
-
"allow", `Allow;
129
-
"deny", `Deny;
130
-
"ask", `Ask;
131
-
]
127
+
Jsont.enum [ ("allow", `Allow); ("deny", `Deny); ("ask", `Ask) ]
132
128
133
129
type output = {
134
-
permission_decision: permission_decision option;
135
-
permission_decision_reason: string option;
136
-
updated_input: Jsont.json option;
130
+
permission_decision : permission_decision option;
131
+
permission_decision_reason : string option;
132
+
updated_input : Jsont.json option;
137
133
unknown : Unknown.t;
138
134
}
139
135
140
136
let output_jsont : output Jsont.t =
141
-
let make permission_decision permission_decision_reason updated_input unknown =
142
-
{ permission_decision; permission_decision_reason; updated_input; unknown }
137
+
let make permission_decision permission_decision_reason updated_input
138
+
unknown =
139
+
{
140
+
permission_decision;
141
+
permission_decision_reason;
142
+
updated_input;
143
+
unknown;
144
+
}
143
145
in
144
146
Jsont.Object.map ~kind:"PreToolUseOutput" make
145
-
|> Jsont.Object.opt_mem "permissionDecision" permission_decision_jsont ~enc:(fun o -> o.permission_decision)
146
-
|> Jsont.Object.opt_mem "permissionDecisionReason" Jsont.string ~enc:(fun o -> o.permission_decision_reason)
147
-
|> Jsont.Object.opt_mem "updatedInput" Jsont.json ~enc:(fun o -> o.updated_input)
147
+
|> Jsont.Object.opt_mem "permissionDecision" permission_decision_jsont
148
+
~enc:(fun o -> o.permission_decision)
149
+
|> Jsont.Object.opt_mem "permissionDecisionReason" Jsont.string
150
+
~enc:(fun o -> o.permission_decision_reason)
151
+
|> Jsont.Object.opt_mem "updatedInput" Jsont.json ~enc:(fun o ->
152
+
o.updated_input)
148
153
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun o -> o.unknown)
149
154
|> Jsont.Object.finish
150
155
···
154
159
| Error msg -> failwith ("PreToolUse.output_to_json: " ^ msg)
155
160
156
161
let allow ?reason ?updated_input ?(unknown = Unknown.empty) () =
157
-
{ permission_decision = Some `Allow; permission_decision_reason = reason;
158
-
updated_input; unknown }
162
+
{
163
+
permission_decision = Some `Allow;
164
+
permission_decision_reason = reason;
165
+
updated_input;
166
+
unknown;
167
+
}
159
168
160
169
let deny ?reason ?(unknown = Unknown.empty) () =
161
-
{ permission_decision = Some `Deny; permission_decision_reason = reason;
162
-
updated_input = None; unknown }
170
+
{
171
+
permission_decision = Some `Deny;
172
+
permission_decision_reason = reason;
173
+
updated_input = None;
174
+
unknown;
175
+
}
163
176
164
177
let ask ?reason ?(unknown = Unknown.empty) () =
165
-
{ permission_decision = Some `Ask; permission_decision_reason = reason;
166
-
updated_input = None; unknown }
178
+
{
179
+
permission_decision = Some `Ask;
180
+
permission_decision_reason = reason;
181
+
updated_input = None;
182
+
unknown;
183
+
}
167
184
168
185
let continue ?(unknown = Unknown.empty) () =
169
-
{ permission_decision = None; permission_decision_reason = None;
170
-
updated_input = None; unknown }
186
+
{
187
+
permission_decision = None;
188
+
permission_decision_reason = None;
189
+
updated_input = None;
190
+
unknown;
191
+
}
171
192
end
172
193
173
194
(** {1 PostToolUse Hook} *)
174
195
module PostToolUse = struct
175
196
type input = {
176
-
session_id: string;
177
-
transcript_path: string;
178
-
tool_name: string;
179
-
tool_input: Jsont.json;
180
-
tool_response: Jsont.json;
197
+
session_id : string;
198
+
transcript_path : string;
199
+
tool_name : string;
200
+
tool_input : Jsont.json;
201
+
tool_response : Jsont.json;
181
202
unknown : Unknown.t;
182
203
}
183
204
···
191
212
let unknown t = t.unknown
192
213
193
214
let input_jsont : input Jsont.t =
194
-
let make session_id transcript_path tool_name tool_input tool_response unknown =
195
-
{ session_id; transcript_path; tool_name; tool_input; tool_response; unknown }
215
+
let make session_id transcript_path tool_name tool_input tool_response
216
+
unknown =
217
+
{
218
+
session_id;
219
+
transcript_path;
220
+
tool_name;
221
+
tool_input;
222
+
tool_response;
223
+
unknown;
224
+
}
196
225
in
197
226
Jsont.Object.map ~kind:"PostToolUseInput" make
198
227
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
···
209
238
| Error msg -> raise (Invalid_argument ("PostToolUse: " ^ msg))
210
239
211
240
type output = {
212
-
decision: decision option;
213
-
reason: string option;
214
-
additional_context: string option;
241
+
decision : decision option;
242
+
reason : string option;
243
+
additional_context : string option;
215
244
unknown : Unknown.t;
216
245
}
217
246
···
222
251
Jsont.Object.map ~kind:"PostToolUseOutput" make
223
252
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o -> o.decision)
224
253
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
225
-
|> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o -> o.additional_context)
254
+
|> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o ->
255
+
o.additional_context)
226
256
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun o -> o.unknown)
227
257
|> Jsont.Object.finish
228
258
···
241
271
(** {1 UserPromptSubmit Hook} *)
242
272
module UserPromptSubmit = struct
243
273
type input = {
244
-
session_id: string;
245
-
transcript_path: string;
246
-
prompt: string;
274
+
session_id : string;
275
+
transcript_path : string;
276
+
prompt : string;
247
277
unknown : Unknown.t;
248
278
}
249
279
···
271
301
| Error msg -> raise (Invalid_argument ("UserPromptSubmit: " ^ msg))
272
302
273
303
type output = {
274
-
decision: decision option;
275
-
reason: string option;
276
-
additional_context: string option;
304
+
decision : decision option;
305
+
reason : string option;
306
+
additional_context : string option;
277
307
unknown : Unknown.t;
278
308
}
279
309
···
284
314
Jsont.Object.map ~kind:"UserPromptSubmitOutput" make
285
315
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o -> o.decision)
286
316
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
287
-
|> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o -> o.additional_context)
317
+
|> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o ->
318
+
o.additional_context)
288
319
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun o -> o.unknown)
289
320
|> Jsont.Object.finish
290
321
···
303
334
(** {1 Stop Hook} *)
304
335
module Stop = struct
305
336
type input = {
306
-
session_id: string;
307
-
transcript_path: string;
308
-
stop_hook_active: bool;
337
+
session_id : string;
338
+
transcript_path : string;
339
+
stop_hook_active : bool;
309
340
unknown : Unknown.t;
310
341
}
311
342
···
333
364
| Error msg -> raise (Invalid_argument ("Stop: " ^ msg))
334
365
335
366
type output = {
336
-
decision: decision option;
337
-
reason: string option;
367
+
decision : decision option;
368
+
reason : string option;
338
369
unknown : Unknown.t;
339
370
}
340
371
341
372
let output_jsont : output Jsont.t =
342
-
let make decision reason unknown =
343
-
{ decision; reason; unknown }
344
-
in
373
+
let make decision reason unknown = { decision; reason; unknown } in
345
374
Jsont.Object.map ~kind:"StopOutput" make
346
375
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o -> o.decision)
347
376
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
···
353
382
| Ok json -> json
354
383
| Error msg -> failwith ("Stop.output_to_json: " ^ msg)
355
384
356
-
let continue ?(unknown = Unknown.empty) () = { decision = None; reason = None; unknown }
357
-
let block ?reason ?(unknown = Unknown.empty) () = { decision = Some Block; reason; unknown }
385
+
let continue ?(unknown = Unknown.empty) () =
386
+
{ decision = None; reason = None; unknown }
387
+
388
+
let block ?reason ?(unknown = Unknown.empty) () =
389
+
{ decision = Some Block; reason; unknown }
358
390
end
359
391
360
392
(** {1 SubagentStop Hook} - Same structure as Stop *)
···
365
397
(** {1 PreCompact Hook} *)
366
398
module PreCompact = struct
367
399
type input = {
368
-
session_id: string;
369
-
transcript_path: string;
400
+
session_id : string;
401
+
transcript_path : string;
370
402
unknown : Unknown.t;
371
403
}
372
404
···
391
423
| Ok v -> v
392
424
| Error msg -> raise (Invalid_argument ("PreCompact: " ^ msg))
393
425
394
-
type output = unit (* No specific output for PreCompact *)
426
+
type output = unit (* No specific output for PreCompact *)
395
427
396
428
let output_to_json () = Jsont.Object ([], Jsont.Meta.none)
397
-
398
429
let continue () = ()
399
430
end
400
431
401
-
(** {1 Generic Callback Type} *)
402
432
type callback =
403
-
input:Jsont.json ->
404
-
tool_use_id:string option ->
405
-
context:Context.t ->
406
-
result
433
+
input:Jsont.json -> tool_use_id:string option -> context:Context.t -> result
434
+
(** {1 Generic Callback Type} *)
407
435
436
+
type matcher = { matcher : string option; callbacks : callback list }
408
437
(** {1 Matcher Configuration} *)
409
-
type matcher = {
410
-
matcher: string option;
411
-
callbacks: callback list;
412
-
}
413
438
414
439
type config = (event * matcher list) list
415
440
416
441
(** {1 Result Builders} *)
417
-
let continue ?system_message ?hook_specific_output ?(unknown = Unknown.empty) () =
442
+
let continue ?system_message ?hook_specific_output ?(unknown = Unknown.empty) ()
443
+
=
418
444
{ decision = None; system_message; hook_specific_output; unknown }
419
445
420
446
let block ?system_message ?hook_specific_output ?(unknown = Unknown.empty) () =
···
426
452
(** {1 Config Builders} *)
427
453
let empty = []
428
454
429
-
let add event matchers config =
430
-
(event, matchers) :: config
455
+
let add event matchers config = (event, matchers) :: config
431
456
432
457
(** {1 JSON Conversion} *)
433
458
let result_to_json result =
···
443
468
let make matcher callbacks = { matcher; callbacks } in
444
469
Jsont.Object.map ~kind:"ProtocolMatcher" make
445
470
|> Jsont.Object.opt_mem "matcher" Jsont.string ~enc:(fun r -> r.matcher)
446
-
|> Jsont.Object.mem "callbacks" (Jsont.list Jsont.json) ~enc:(fun r -> r.callbacks)
471
+
|> Jsont.Object.mem "callbacks" (Jsont.list Jsont.json) ~enc:(fun r ->
472
+
r.callbacks)
447
473
|> Jsont.Object.finish
448
474
449
475
let encode m =
···
453
479
end
454
480
455
481
let config_to_protocol_format config =
456
-
let hooks_dict = List.map (fun (event, matchers) ->
457
-
let event_name = event_to_string event in
458
-
let matchers_json = List.map (fun m ->
459
-
(* matcher and hookCallbackIds will be filled in by client *)
460
-
Protocol_matcher_wire.encode { matcher = m.matcher; callbacks = [] }
461
-
) matchers in
462
-
Jsont.Json.mem (Jsont.Json.name event_name) (Jsont.Json.list matchers_json)
463
-
) config in
482
+
let hooks_dict =
483
+
List.map
484
+
(fun (event, matchers) ->
485
+
let event_name = event_to_string event in
486
+
let matchers_json =
487
+
List.map
488
+
(fun m ->
489
+
(* matcher and hookCallbackIds will be filled in by client *)
490
+
Protocol_matcher_wire.encode
491
+
{ matcher = m.matcher; callbacks = [] })
492
+
matchers
493
+
in
494
+
Jsont.Json.mem
495
+
(Jsont.Json.name event_name)
496
+
(Jsont.Json.list matchers_json))
497
+
config
498
+
in
464
499
Jsont.Json.object' hooks_dict
+107
-96
lib/hooks.mli
+107
-96
lib/hooks.mli
···
49
49
50
50
let options = Claude.Options.create ~hooks:(Some hooks) () in
51
51
let client = Claude.Client.create ~options ~sw ~process_mgr () in
52
-
]}
53
-
*)
52
+
]} *)
54
53
54
+
val src : Logs.Src.t
55
55
(** The log source for hooks *)
56
-
val src : Logs.Src.t
57
56
58
57
(** {1 Hook Events} *)
59
58
60
59
(** Hook event types *)
61
60
type event =
62
-
| Pre_tool_use (** Fires before a tool is executed *)
63
-
| Post_tool_use (** Fires after a tool completes *)
64
-
| User_prompt_submit (** Fires when user submits a prompt *)
65
-
| Stop (** Fires when conversation stops *)
66
-
| Subagent_stop (** Fires when a subagent stops *)
67
-
| Pre_compact (** Fires before message compaction *)
61
+
| Pre_tool_use (** Fires before a tool is executed *)
62
+
| Post_tool_use (** Fires after a tool completes *)
63
+
| User_prompt_submit (** Fires when user submits a prompt *)
64
+
| Stop (** Fires when conversation stops *)
65
+
| Subagent_stop (** Fires when a subagent stops *)
66
+
| Pre_compact (** Fires before message compaction *)
68
67
69
68
val event_to_string : event -> string
70
69
val event_of_string : string -> event
···
73
72
(** {1 Context} *)
74
73
75
74
module Context : sig
76
-
type t = {
77
-
signal: unit option;
78
-
unknown : Unknown.t;
79
-
}
75
+
type t = { signal : unit option; unknown : Unknown.t }
80
76
81
77
val create : ?signal:unit option -> ?unknown:Unknown.t -> unit -> t
82
78
val signal : t -> unit option
···
88
84
89
85
type decision =
90
86
| Continue (** Allow the action to proceed *)
91
-
| Block (** Block the action *)
87
+
| Block (** Block the action *)
92
88
93
89
val decision_jsont : decision Jsont.t
94
90
95
91
(** {1 Generic Hook Result} *)
96
92
97
-
(** Generic result structure for hooks *)
98
93
type result = {
99
-
decision: decision option;
100
-
system_message: string option;
101
-
hook_specific_output: Jsont.json option;
102
-
unknown: Unknown.t;
94
+
decision : decision option;
95
+
system_message : string option;
96
+
hook_specific_output : Jsont.json option;
97
+
unknown : Unknown.t;
103
98
}
99
+
(** Generic result structure for hooks *)
104
100
105
101
val result_jsont : result Jsont.t
106
102
···
108
104
109
105
(** PreToolUse hook - fires before tool execution *)
110
106
module PreToolUse : sig
111
-
(** Typed input for PreToolUse hooks *)
112
107
type input = {
113
-
session_id: string;
114
-
transcript_path: string;
115
-
tool_name: string;
116
-
tool_input: Jsont.json;
117
-
unknown: Unknown.t;
108
+
session_id : string;
109
+
transcript_path : string;
110
+
tool_name : string;
111
+
tool_input : Jsont.json;
112
+
unknown : Unknown.t;
118
113
}
114
+
(** Typed input for PreToolUse hooks *)
119
115
120
116
type t = input
121
117
122
-
(** Parse hook input from JSON *)
123
118
val of_json : Jsont.json -> t
119
+
(** Parse hook input from JSON *)
124
120
121
+
val session_id : t -> string
125
122
(** {2 Accessors} *)
126
-
val session_id : t -> string
123
+
127
124
val transcript_path : t -> string
128
125
val tool_name : t -> string
129
126
val tool_input : t -> Jsont.json
130
127
val unknown : t -> Unknown.t
131
-
132
128
val input_jsont : input Jsont.t
133
129
134
-
(** Permission decision for tool usage *)
135
130
type permission_decision = [ `Allow | `Deny | `Ask ]
131
+
(** Permission decision for tool usage *)
136
132
137
133
val permission_decision_jsont : permission_decision Jsont.t
138
134
139
-
(** Typed output for PreToolUse hooks *)
140
135
type output = {
141
-
permission_decision: permission_decision option;
142
-
permission_decision_reason: string option;
143
-
updated_input: Jsont.json option;
144
-
unknown: Unknown.t;
136
+
permission_decision : permission_decision option;
137
+
permission_decision_reason : string option;
138
+
updated_input : Jsont.json option;
139
+
unknown : Unknown.t;
145
140
}
141
+
(** Typed output for PreToolUse hooks *)
146
142
147
143
val output_jsont : output Jsont.t
148
144
145
+
val allow :
146
+
?reason:string ->
147
+
?updated_input:Jsont.json ->
148
+
?unknown:Unknown.t ->
149
+
unit ->
150
+
output
149
151
(** {2 Response Builders} *)
150
-
val allow : ?reason:string -> ?updated_input:Jsont.json -> ?unknown:Unknown.t -> unit -> output
152
+
151
153
val deny : ?reason:string -> ?unknown:Unknown.t -> unit -> output
152
154
val ask : ?reason:string -> ?unknown:Unknown.t -> unit -> output
153
155
val continue : ?unknown:Unknown.t -> unit -> output
154
156
155
-
(** Convert output to JSON for hook_specific_output *)
156
157
val output_to_json : output -> Jsont.json
158
+
(** Convert output to JSON for hook_specific_output *)
157
159
end
158
160
159
161
(** PostToolUse hook - fires after tool execution *)
160
162
module PostToolUse : sig
161
163
type input = {
162
-
session_id: string;
163
-
transcript_path: string;
164
-
tool_name: string;
165
-
tool_input: Jsont.json;
166
-
tool_response: Jsont.json;
167
-
unknown: Unknown.t;
164
+
session_id : string;
165
+
transcript_path : string;
166
+
tool_name : string;
167
+
tool_input : Jsont.json;
168
+
tool_response : Jsont.json;
169
+
unknown : Unknown.t;
168
170
}
169
171
170
172
type t = input
171
173
172
174
val of_json : Jsont.json -> t
173
-
174
175
val session_id : t -> string
175
176
val transcript_path : t -> string
176
177
val tool_name : t -> string
177
178
val tool_input : t -> Jsont.json
178
179
val tool_response : t -> Jsont.json
179
180
val unknown : t -> Unknown.t
180
-
181
181
val input_jsont : input Jsont.t
182
182
183
183
type output = {
184
-
decision: decision option;
185
-
reason: string option;
186
-
additional_context: string option;
187
-
unknown: Unknown.t;
184
+
decision : decision option;
185
+
reason : string option;
186
+
additional_context : string option;
187
+
unknown : Unknown.t;
188
188
}
189
189
190
190
val output_jsont : output Jsont.t
191
191
192
-
val continue : ?additional_context:string -> ?unknown:Unknown.t -> unit -> output
193
-
val block : ?reason:string -> ?additional_context:string -> ?unknown:Unknown.t -> unit -> output
192
+
val continue :
193
+
?additional_context:string -> ?unknown:Unknown.t -> unit -> output
194
+
195
+
val block :
196
+
?reason:string ->
197
+
?additional_context:string ->
198
+
?unknown:Unknown.t ->
199
+
unit ->
200
+
output
201
+
194
202
val output_to_json : output -> Jsont.json
195
203
end
196
204
197
205
(** UserPromptSubmit hook - fires when user submits a prompt *)
198
206
module UserPromptSubmit : sig
199
207
type input = {
200
-
session_id: string;
201
-
transcript_path: string;
202
-
prompt: string;
203
-
unknown: Unknown.t;
208
+
session_id : string;
209
+
transcript_path : string;
210
+
prompt : string;
211
+
unknown : Unknown.t;
204
212
}
205
213
206
214
type t = input
207
215
208
216
val of_json : Jsont.json -> t
209
-
210
217
val session_id : t -> string
211
218
val transcript_path : t -> string
212
219
val prompt : t -> string
213
220
val unknown : t -> Unknown.t
214
-
215
221
val input_jsont : input Jsont.t
216
222
217
223
type output = {
218
-
decision: decision option;
219
-
reason: string option;
220
-
additional_context: string option;
221
-
unknown: Unknown.t;
224
+
decision : decision option;
225
+
reason : string option;
226
+
additional_context : string option;
227
+
unknown : Unknown.t;
222
228
}
223
229
224
230
val output_jsont : output Jsont.t
225
231
226
-
val continue : ?additional_context:string -> ?unknown:Unknown.t -> unit -> output
232
+
val continue :
233
+
?additional_context:string -> ?unknown:Unknown.t -> unit -> output
234
+
227
235
val block : ?reason:string -> ?unknown:Unknown.t -> unit -> output
228
236
val output_to_json : output -> Jsont.json
229
237
end
···
231
239
(** Stop hook - fires when conversation stops *)
232
240
module Stop : sig
233
241
type input = {
234
-
session_id: string;
235
-
transcript_path: string;
236
-
stop_hook_active: bool;
237
-
unknown: Unknown.t;
242
+
session_id : string;
243
+
transcript_path : string;
244
+
stop_hook_active : bool;
245
+
unknown : Unknown.t;
238
246
}
239
247
240
248
type t = input
241
249
242
250
val of_json : Jsont.json -> t
243
-
244
251
val session_id : t -> string
245
252
val transcript_path : t -> string
246
253
val stop_hook_active : t -> bool
247
254
val unknown : t -> Unknown.t
248
-
249
255
val input_jsont : input Jsont.t
250
256
251
257
type output = {
252
-
decision: decision option;
253
-
reason: string option;
254
-
unknown: Unknown.t;
258
+
decision : decision option;
259
+
reason : string option;
260
+
unknown : Unknown.t;
255
261
}
256
262
257
263
val output_jsont : output Jsont.t
258
-
259
264
val continue : ?unknown:Unknown.t -> unit -> output
260
265
val block : ?reason:string -> ?unknown:Unknown.t -> unit -> output
261
266
val output_to_json : output -> Jsont.json
···
264
269
(** SubagentStop hook - fires when a subagent stops *)
265
270
module SubagentStop : sig
266
271
include module type of Stop
272
+
267
273
val of_json : Jsont.json -> t
268
274
end
269
275
270
276
(** PreCompact hook - fires before message compaction *)
271
277
module PreCompact : sig
272
278
type input = {
273
-
session_id: string;
274
-
transcript_path: string;
275
-
unknown: Unknown.t;
279
+
session_id : string;
280
+
transcript_path : string;
281
+
unknown : Unknown.t;
276
282
}
277
283
278
284
type t = input
279
-
280
285
type output = unit
281
286
282
287
val of_json : Jsont.json -> t
283
-
284
288
val session_id : t -> string
285
289
val transcript_path : t -> string
286
290
val unknown : t -> Unknown.t
287
-
288
291
val input_jsont : input Jsont.t
289
-
290
292
val continue : unit -> output
291
293
val output_to_json : output -> Jsont.json
292
294
end
293
295
294
296
(** {1 Callbacks} *)
295
297
298
+
type callback =
299
+
input:Jsont.json -> tool_use_id:string option -> context:Context.t -> result
296
300
(** Generic callback function type.
297
301
298
302
Callbacks receive:
···
300
304
- [tool_use_id]: Optional tool use ID
301
305
- [context]: Hook context
302
306
303
-
And return a generic [result] with optional hook-specific output.
304
-
*)
305
-
type callback =
306
-
input:Jsont.json ->
307
-
tool_use_id:string option ->
308
-
context:Context.t ->
309
-
result
307
+
And return a generic [result] with optional hook-specific output. *)
310
308
311
309
(** {1 Matchers} *)
312
310
313
-
(** A matcher configuration *)
314
311
type matcher = {
315
-
matcher: string option; (** Pattern to match (e.g., "Bash" or "Write|Edit") *)
316
-
callbacks: callback list; (** Callbacks to invoke on match *)
312
+
matcher : string option;
313
+
(** Pattern to match (e.g., "Bash" or "Write|Edit") *)
314
+
callbacks : callback list; (** Callbacks to invoke on match *)
317
315
}
316
+
(** A matcher configuration *)
318
317
319
-
(** Hook configuration: map from events to matchers *)
320
318
type config = (event * matcher list) list
319
+
(** Hook configuration: map from events to matchers *)
321
320
322
321
(** {1 Generic Result Builders} *)
323
322
324
-
(** [continue ?system_message ?hook_specific_output ?unknown ()] creates a continue result *)
325
-
val continue : ?system_message:string -> ?hook_specific_output:Jsont.json -> ?unknown:Unknown.t -> unit -> result
323
+
val continue :
324
+
?system_message:string ->
325
+
?hook_specific_output:Jsont.json ->
326
+
?unknown:Unknown.t ->
327
+
unit ->
328
+
result
329
+
(** [continue ?system_message ?hook_specific_output ?unknown ()] creates a
330
+
continue result *)
326
331
327
-
(** [block ?system_message ?hook_specific_output ?unknown ()] creates a block result *)
328
-
val block : ?system_message:string -> ?hook_specific_output:Jsont.json -> ?unknown:Unknown.t -> unit -> result
332
+
val block :
333
+
?system_message:string ->
334
+
?hook_specific_output:Jsont.json ->
335
+
?unknown:Unknown.t ->
336
+
unit ->
337
+
result
338
+
(** [block ?system_message ?hook_specific_output ?unknown ()] creates a block
339
+
result *)
329
340
330
341
(** {1 Configuration Builders} *)
331
342
332
-
(** [matcher ?pattern callbacks] creates a matcher *)
333
343
val matcher : ?pattern:string -> callback list -> matcher
344
+
(** [matcher ?pattern callbacks] creates a matcher *)
334
345
335
-
(** Empty hooks configuration *)
336
346
val empty : config
347
+
(** Empty hooks configuration *)
337
348
349
+
val add : event -> matcher list -> config -> config
338
350
(** [add event matchers config] adds matchers for an event *)
339
-
val add : event -> matcher list -> config -> config
340
351
341
352
(** {1 JSON Serialization} *)
342
353
+65
-47
lib/incoming.ml
+65
-47
lib/incoming.ml
···
1
-
let src = Logs.Src.create "claude.incoming" ~doc:"Incoming messages from Claude CLI"
1
+
let src =
2
+
Logs.Src.create "claude.incoming" ~doc:"Incoming messages from Claude CLI"
3
+
2
4
module Log = (val Logs.src_log src : Logs.LOG)
3
5
4
6
(** Control request types for incoming control_request messages *)
···
17
19
18
20
let jsont : t Jsont.t =
19
21
let make tool_name input permission_suggestions =
20
-
{ tool_name; input; permission_suggestions = Option.value permission_suggestions ~default:[] }
22
+
{
23
+
tool_name;
24
+
input;
25
+
permission_suggestions =
26
+
Option.value permission_suggestions ~default:[];
27
+
}
21
28
in
22
29
Jsont.Object.map ~kind:"CanUseTool" make
23
30
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:tool_name
24
31
|> Jsont.Object.mem "input" Jsont.json ~enc:input
25
32
|> Jsont.Object.opt_mem "permission_suggestions" (Jsont.list Jsont.json)
26
-
~enc:(fun t -> if t.permission_suggestions = [] then None else Some t.permission_suggestions)
33
+
~enc:(fun t ->
34
+
if t.permission_suggestions = [] then None
35
+
else Some t.permission_suggestions)
27
36
|> Jsont.Object.finish
28
37
end
29
38
···
40
49
let tool_use_id t = t.tool_use_id
41
50
42
51
let jsont : t Jsont.t =
43
-
let make callback_id input tool_use_id = { callback_id; input; tool_use_id } in
52
+
let make callback_id input tool_use_id =
53
+
{ callback_id; input; tool_use_id }
54
+
in
44
55
Jsont.Object.map ~kind:"HookCallback" make
45
56
|> Jsont.Object.mem "callback_id" Jsont.string ~enc:callback_id
46
57
|> Jsont.Object.mem "input" Jsont.json ~enc:input
···
55
66
| Unknown of string * Jsont.json
56
67
57
68
let request_of_json json =
58
-
let subtype_codec = Jsont.Object.map ~kind:"Subtype" Fun.id
69
+
let subtype_codec =
70
+
Jsont.Object.map ~kind:"Subtype" Fun.id
59
71
|> Jsont.Object.mem "subtype" Jsont.string ~enc:Fun.id
60
72
|> Jsont.Object.finish
61
73
in
62
74
match Jsont.Json.decode subtype_codec json with
63
75
| Error _ -> Unknown ("unknown", json)
64
-
| Ok subtype ->
76
+
| Ok subtype -> (
65
77
match subtype with
66
-
| "can_use_tool" ->
67
-
(match Jsont.Json.decode Can_use_tool.jsont json with
78
+
| "can_use_tool" -> (
79
+
match Jsont.Json.decode Can_use_tool.jsont json with
68
80
| Ok r -> Can_use_tool r
69
81
| Error _ -> Unknown (subtype, json))
70
-
| "hook_callback" ->
71
-
(match Jsont.Json.decode Hook_callback.jsont json with
82
+
| "hook_callback" -> (
83
+
match Jsont.Json.decode Hook_callback.jsont json with
72
84
| Ok r -> Hook_callback r
73
85
| Error _ -> Unknown (subtype, json))
74
-
| _ -> Unknown (subtype, json)
86
+
| _ -> Unknown (subtype, json))
75
87
88
+
type t = { request_id : string; request : request }
76
89
(** Full control request message *)
77
-
type t = {
78
-
request_id : string;
79
-
request : request;
80
-
}
81
90
82
91
let request_id t = t.request_id
83
92
let request t = t.request
···
91
100
let jsont : t Jsont.t =
92
101
let dec json =
93
102
let envelope_codec =
94
-
Jsont.Object.map ~kind:"ControlRequestEnvelope" (fun request_id request_json -> (request_id, request_json))
103
+
Jsont.Object.map ~kind:"ControlRequestEnvelope"
104
+
(fun request_id request_json -> (request_id, request_json))
95
105
|> Jsont.Object.mem "request_id" Jsont.string ~enc:fst
96
106
|> Jsont.Object.mem "request" Jsont.json ~enc:snd
97
107
|> Jsont.Object.finish
98
108
in
99
109
match Jsont.Json.decode envelope_codec json with
100
-
| Error err -> failwith ("Failed to decode control_request envelope: " ^ err)
110
+
| Error err ->
111
+
failwith ("Failed to decode control_request envelope: " ^ err)
101
112
| Ok (request_id, request_json) ->
102
113
{ request_id; request = request_of_json request_json }
103
114
in
104
115
let enc t =
105
-
let request_json = match t.request with
106
-
| Can_use_tool r ->
107
-
(match Jsont.Json.encode Can_use_tool.jsont r with
116
+
let request_json =
117
+
match t.request with
118
+
| Can_use_tool r -> (
119
+
match Jsont.Json.encode Can_use_tool.jsont r with
108
120
| Ok j -> j
109
121
| Error err -> failwith ("Failed to encode Can_use_tool: " ^ err))
110
-
| Hook_callback r ->
111
-
(match Jsont.Json.encode Hook_callback.jsont r with
122
+
| Hook_callback r -> (
123
+
match Jsont.Json.encode Hook_callback.jsont r with
112
124
| Ok j -> j
113
125
| Error err -> failwith ("Failed to encode Hook_callback: " ^ err))
114
126
| Unknown (_, j) -> j
115
127
in
116
-
Jsont.Json.object' [
117
-
Jsont.Json.mem (Jsont.Json.name "type") (Jsont.Json.string "control_request");
118
-
Jsont.Json.mem (Jsont.Json.name "request_id") (Jsont.Json.string t.request_id);
119
-
Jsont.Json.mem (Jsont.Json.name "request") request_json;
120
-
]
128
+
Jsont.Json.object'
129
+
[
130
+
Jsont.Json.mem (Jsont.Json.name "type")
131
+
(Jsont.Json.string "control_request");
132
+
Jsont.Json.mem
133
+
(Jsont.Json.name "request_id")
134
+
(Jsont.Json.string t.request_id);
135
+
Jsont.Json.mem (Jsont.Json.name "request") request_json;
136
+
]
121
137
in
122
138
Jsont.map ~kind:"ControlRequest" ~dec ~enc Jsont.json
123
139
end
···
134
150
"system", "result"), while control_response and control_request have single type values.
135
151
Jsont's case_mem discriminator doesn't support multiple tags per case, so we implement
136
152
a custom decoder/encoder. *)
137
-
138
-
let type_field_codec = Jsont.Object.map ~kind:"type_field" Fun.id
153
+
let type_field_codec =
154
+
Jsont.Object.map ~kind:"type_field" Fun.id
139
155
|> Jsont.Object.opt_mem "type" Jsont.string ~enc:Fun.id
140
156
|> Jsont.Object.finish
141
157
in
142
158
143
159
let dec json =
144
160
match Jsont.Json.decode type_field_codec json with
145
-
| Error _ | Ok None ->
161
+
| Error _ | Ok None -> (
146
162
(* No type field, try as message *)
147
-
(match Jsont.Json.decode Message.jsont json with
163
+
match Jsont.Json.decode Message.jsont json with
148
164
| Ok msg -> Message msg
149
165
| Error err -> failwith ("Failed to decode message: " ^ err))
150
-
| Ok (Some typ) ->
166
+
| Ok (Some typ) -> (
151
167
match typ with
152
-
| "control_response" ->
153
-
(match Jsont.Json.decode Sdk_control.control_response_jsont json with
168
+
| "control_response" -> (
169
+
match Jsont.Json.decode Sdk_control.control_response_jsont json with
154
170
| Ok resp -> Control_response resp
155
-
| Error err -> failwith ("Failed to decode control_response: " ^ err))
156
-
| "control_request" ->
157
-
(match Jsont.Json.decode Control_request.jsont json with
171
+
| Error err -> failwith ("Failed to decode control_response: " ^ err)
172
+
)
173
+
| "control_request" -> (
174
+
match Jsont.Json.decode Control_request.jsont json with
158
175
| Ok req -> Control_request req
159
-
| Error err -> failwith ("Failed to decode control_request: " ^ err))
160
-
| "user" | "assistant" | "system" | "result" | _ ->
176
+
| Error err -> failwith ("Failed to decode control_request: " ^ err)
177
+
)
178
+
| "user" | "assistant" | "system" | "result" | _ -> (
161
179
(* Message types *)
162
-
(match Jsont.Json.decode Message.jsont json with
180
+
match Jsont.Json.decode Message.jsont json with
163
181
| Ok msg -> Message msg
164
-
| Error err -> failwith ("Failed to decode message: " ^ err))
182
+
| Error err -> failwith ("Failed to decode message: " ^ err)))
165
183
in
166
184
167
185
let enc = function
168
-
| Message msg ->
169
-
(match Jsont.Json.encode Message.jsont msg with
186
+
| Message msg -> (
187
+
match Jsont.Json.encode Message.jsont msg with
170
188
| Ok json -> json
171
189
| Error err -> failwith ("Failed to encode message: " ^ err))
172
-
| Control_response resp ->
173
-
(match Jsont.Json.encode Sdk_control.control_response_jsont resp with
190
+
| Control_response resp -> (
191
+
match Jsont.Json.encode Sdk_control.control_response_jsont resp with
174
192
| Ok json -> json
175
193
| Error err -> failwith ("Failed to encode control response: " ^ err))
176
-
| Control_request req ->
177
-
(match Jsont.Json.encode Control_request.jsont req with
194
+
| Control_request req -> (
195
+
match Jsont.Json.encode Control_request.jsont req with
178
196
| Ok json -> json
179
197
| Error err -> failwith ("Failed to encode control request: " ^ err))
180
198
in
+5
-5
lib/incoming.mli
+5
-5
lib/incoming.mli
···
1
1
(** Incoming messages from the Claude CLI.
2
2
3
-
This module defines a discriminated union of all possible message types
4
-
that can be received from the Claude CLI, with a single jsont codec.
3
+
This module defines a discriminated union of all possible message types that
4
+
can be received from the Claude CLI, with a single jsont codec.
5
5
6
6
The codec uses the "type" field to discriminate between message types:
7
7
- "user", "assistant", "system", "result" -> Message variant
···
39
39
| Hook_callback of Hook_callback.t
40
40
| Unknown of string * Jsont.json
41
41
42
-
(** Full control request message *)
43
42
type t
43
+
(** Full control request message *)
44
44
45
45
val request_id : t -> string
46
46
val request : t -> request
···
54
54
| Control_request of Control_request.t
55
55
56
56
val jsont : t Jsont.t
57
-
(** Codec for incoming messages. Uses the "type" field to discriminate.
58
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
57
+
(** Codec for incoming messages. Uses the "type" field to discriminate. Use
58
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
+267
-221
lib/message.ml
+267
-221
lib/message.ml
···
1
1
let src = Logs.Src.create "claude.message" ~doc:"Claude messages"
2
-
module Log = (val Logs.src_log src : Logs.LOG)
3
2
3
+
module Log = (val Logs.src_log src : Logs.LOG)
4
4
5
5
module User = struct
6
-
type content =
7
-
| String of string
8
-
| Blocks of Content_block.t list
9
-
10
-
type t = {
11
-
content : content;
12
-
unknown : Unknown.t;
13
-
}
6
+
type content = String of string | Blocks of Content_block.t list
7
+
type t = { content : content; unknown : Unknown.t }
14
8
15
9
let create_string s = { content = String s; unknown = Unknown.empty }
16
-
let create_blocks blocks = { content = Blocks blocks; unknown = Unknown.empty }
10
+
11
+
let create_blocks blocks =
12
+
{ content = Blocks blocks; unknown = Unknown.empty }
17
13
18
14
let create_with_tool_result ~tool_use_id ~content ?is_error () =
19
-
let tool_result = Content_block.tool_result ~tool_use_id ~content ?is_error () in
20
-
{ content = Blocks [tool_result]; unknown = Unknown.empty }
15
+
let tool_result =
16
+
Content_block.tool_result ~tool_use_id ~content ?is_error ()
17
+
in
18
+
{ content = Blocks [ tool_result ]; unknown = Unknown.empty }
21
19
22
20
let create_mixed ~text ~tool_results =
23
21
let blocks =
24
-
let text_blocks = match text with
25
-
| Some t -> [Content_block.text t]
26
-
| None -> []
22
+
let text_blocks =
23
+
match text with Some t -> [ Content_block.text t ] | None -> []
24
+
in
25
+
let tool_blocks =
26
+
List.map
27
+
(fun (tool_use_id, content, is_error) ->
28
+
Content_block.tool_result ~tool_use_id ~content ?is_error ())
29
+
tool_results
27
30
in
28
-
let tool_blocks = List.map (fun (tool_use_id, content, is_error) ->
29
-
Content_block.tool_result ~tool_use_id ~content ?is_error ()
30
-
) tool_results in
31
31
text_blocks @ tool_blocks
32
32
in
33
33
{ content = Blocks blocks; unknown = Unknown.empty }
···
35
35
let make content unknown = { content; unknown }
36
36
let content t = t.content
37
37
let unknown t = t.unknown
38
+
let as_text t = match t.content with String s -> Some s | Blocks _ -> None
38
39
39
-
let as_text t = match t.content with
40
-
| String s -> Some s
41
-
| Blocks _ -> None
42
-
43
-
let get_blocks t = match t.content with
44
-
| String s -> [Content_block.text s]
40
+
let get_blocks t =
41
+
match t.content with
42
+
| String s -> [ Content_block.text s ]
45
43
| Blocks blocks -> blocks
46
44
47
45
(* Decode content from json value *)
48
-
let decode_content json = match json with
46
+
let decode_content json =
47
+
match json with
49
48
| Jsont.String (s, _) -> String s
50
49
| Jsont.Array (items, _) ->
51
-
let blocks = List.map (fun j ->
52
-
match Jsont.Json.decode Content_block.jsont j with
53
-
| Ok b -> b
54
-
| Error msg -> failwith ("Invalid content block: " ^ msg)
55
-
) items in
50
+
let blocks =
51
+
List.map
52
+
(fun j ->
53
+
Jsont.Json.decode Content_block.jsont j
54
+
|> Err.get_ok ~msg:"Invalid content block: ")
55
+
items
56
+
in
56
57
Blocks blocks
57
58
| _ -> failwith "Content must be string or array"
58
59
···
60
61
let encode_content = function
61
62
| String s -> Jsont.String (s, Jsont.Meta.none)
62
63
| Blocks blocks ->
63
-
let jsons = List.map (fun b ->
64
-
match Jsont.Json.encode Content_block.jsont b with
65
-
| Ok j -> j
66
-
| Error msg -> failwith ("encode_content: " ^ msg)
67
-
) blocks in
64
+
let jsons =
65
+
List.map
66
+
(fun b ->
67
+
Jsont.Json.encode Content_block.jsont b
68
+
|> Err.get_ok ~msg:"encode_content: ")
69
+
blocks
70
+
in
68
71
Jsont.Array (jsons, Jsont.Meta.none)
69
72
70
73
let jsont : t Jsont.t =
71
74
Jsont.Object.map ~kind:"User" (fun json_content unknown ->
72
-
let content = decode_content json_content in
73
-
make content unknown
74
-
)
75
-
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t -> encode_content (content t))
75
+
let content = decode_content json_content in
76
+
make content unknown)
77
+
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t ->
78
+
encode_content (content t))
76
79
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
77
80
|> Jsont.Object.finish
78
81
···
99
102
100
103
let to_json t =
101
104
let content_json = encode_content t.content in
102
-
let wire = Wire.{
103
-
type_ = "user";
104
-
message = { role = "user"; content = content_json }
105
-
} in
106
-
match Jsont.Json.encode Wire.outer_jsont wire with
107
-
| Ok json -> json
108
-
| Error msg -> failwith ("User.to_json: " ^ msg)
105
+
let wire =
106
+
Wire.
107
+
{ type_ = "user"; message = { role = "user"; content = content_json } }
108
+
in
109
+
Jsont.Json.encode Wire.outer_jsont wire |> Err.get_ok ~msg:"User.to_json: "
109
110
110
111
(* Jsont codec for parsing incoming user messages from CLI *)
111
112
let incoming_jsont : t Jsont.t =
112
113
let message_jsont =
113
114
Jsont.Object.map ~kind:"UserMessage" (fun json_content ->
114
-
let content = decode_content json_content in
115
-
{ content; unknown = Unknown.empty }
116
-
)
117
-
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t -> encode_content (content t))
115
+
let content = decode_content json_content in
116
+
{ content; unknown = Unknown.empty })
117
+
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t ->
118
+
encode_content (content t))
118
119
|> Jsont.Object.finish
119
120
in
120
121
Jsont.Object.map ~kind:"UserEnvelope" Fun.id
···
122
123
|> Jsont.Object.finish
123
124
124
125
let of_json json =
125
-
match Jsont.Json.decode incoming_jsont json with
126
-
| Ok v -> v
127
-
| Error msg -> raise (Invalid_argument ("User.of_json: " ^ msg))
126
+
Jsont.Json.decode incoming_jsont json |> Err.get_ok' ~msg:"User.of_json: "
128
127
end
129
128
130
129
module Assistant = struct
131
-
type error = [
132
-
| `Authentication_failed
130
+
type error =
131
+
[ `Authentication_failed
133
132
| `Billing_error
134
133
| `Rate_limit
135
134
| `Invalid_request
136
135
| `Server_error
137
-
| `Unknown
138
-
]
136
+
| `Unknown ]
139
137
140
138
let error_to_string = function
141
139
| `Authentication_failed -> "authentication_failed"
···
154
152
| "unknown" | _ -> `Unknown
155
153
156
154
let error_jsont : error Jsont.t =
157
-
Jsont.enum [
158
-
("authentication_failed", `Authentication_failed);
159
-
("billing_error", `Billing_error);
160
-
("rate_limit", `Rate_limit);
161
-
("invalid_request", `Invalid_request);
162
-
("server_error", `Server_error);
163
-
("unknown", `Unknown);
164
-
]
155
+
Jsont.enum
156
+
[
157
+
("authentication_failed", `Authentication_failed);
158
+
("billing_error", `Billing_error);
159
+
("rate_limit", `Rate_limit);
160
+
("invalid_request", `Invalid_request);
161
+
("server_error", `Server_error);
162
+
("unknown", `Unknown);
163
+
]
165
164
166
165
type t = {
167
166
content : Content_block.t list;
···
170
169
unknown : Unknown.t;
171
170
}
172
171
173
-
let create ~content ~model ?error () = { content; model; error; unknown = Unknown.empty }
172
+
let create ~content ~model ?error () =
173
+
{ content; model; error; unknown = Unknown.empty }
174
+
174
175
let make content model error unknown = { content; model; error; unknown }
175
176
let content t = t.content
176
177
let model t = t.model
···
178
179
let unknown t = t.unknown
179
180
180
181
let get_text_blocks t =
181
-
List.filter_map (function
182
-
| Content_block.Text text -> Some (Content_block.Text.text text)
183
-
| _ -> None
184
-
) t.content
182
+
List.filter_map
183
+
(function
184
+
| Content_block.Text text -> Some (Content_block.Text.text text)
185
+
| _ -> None)
186
+
t.content
185
187
186
188
let get_tool_uses t =
187
-
List.filter_map (function
188
-
| Content_block.Tool_use tool -> Some tool
189
-
| _ -> None
190
-
) t.content
189
+
List.filter_map
190
+
(function Content_block.Tool_use tool -> Some tool | _ -> None)
191
+
t.content
191
192
192
193
let get_thinking t =
193
-
List.filter_map (function
194
-
| Content_block.Thinking thinking -> Some thinking
195
-
| _ -> None
196
-
) t.content
194
+
List.filter_map
195
+
(function Content_block.Thinking thinking -> Some thinking | _ -> None)
196
+
t.content
197
197
198
198
let has_tool_use t =
199
-
List.exists (function
200
-
| Content_block.Tool_use _ -> true
201
-
| _ -> false
202
-
) t.content
199
+
List.exists
200
+
(function Content_block.Tool_use _ -> true | _ -> false)
201
+
t.content
203
202
204
-
let combined_text t =
205
-
String.concat "\n" (get_text_blocks t)
203
+
let combined_text t = String.concat "\n" (get_text_blocks t)
206
204
207
205
let jsont : t Jsont.t =
208
206
Jsont.Object.map ~kind:"Assistant" make
···
213
211
|> Jsont.Object.finish
214
212
215
213
let encode_content_blocks blocks =
216
-
let jsons = List.map (fun b ->
217
-
match Jsont.Json.encode Content_block.jsont b with
218
-
| Ok j -> j
219
-
| Error msg -> failwith ("encode_content_blocks: " ^ msg)
220
-
) blocks in
214
+
let jsons =
215
+
List.map
216
+
(fun b ->
217
+
Jsont.Json.encode Content_block.jsont b
218
+
|> Err.get_ok ~msg:"encode_content_blocks: ")
219
+
blocks
220
+
in
221
221
Jsont.Array (jsons, Jsont.Meta.none)
222
222
223
223
(** Wire-format codec for outgoing assistant messages. *)
···
227
227
wire_model : string;
228
228
wire_error : string option;
229
229
}
230
+
230
231
type outer = { wire_type : string; wire_message : inner }
231
232
232
233
let inner_jsont : inner Jsont.t =
233
-
let make wire_content wire_model wire_error = { wire_content; wire_model; wire_error } in
234
+
let make wire_content wire_model wire_error =
235
+
{ wire_content; wire_model; wire_error }
236
+
in
234
237
Jsont.Object.map ~kind:"AssistantMessageInner" make
235
238
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun r -> r.wire_content)
236
239
|> Jsont.Object.mem "model" Jsont.string ~enc:(fun r -> r.wire_model)
···
246
249
end
247
250
248
251
let to_json t =
249
-
let wire = Wire.{
250
-
wire_type = "assistant";
251
-
wire_message = {
252
-
wire_content = encode_content_blocks t.content;
253
-
wire_model = t.model;
254
-
wire_error = Option.map error_to_string t.error;
255
-
}
256
-
} in
257
-
match Jsont.Json.encode Wire.outer_jsont wire with
258
-
| Ok json -> json
259
-
| Error msg -> failwith ("Assistant.to_json: " ^ msg)
252
+
let wire =
253
+
Wire.
254
+
{
255
+
wire_type = "assistant";
256
+
wire_message =
257
+
{
258
+
wire_content = encode_content_blocks t.content;
259
+
wire_model = t.model;
260
+
wire_error = Option.map error_to_string t.error;
261
+
};
262
+
}
263
+
in
264
+
Jsont.Json.encode Wire.outer_jsont wire
265
+
|> Err.get_ok ~msg:"Assistant.to_json: "
260
266
261
267
(* Jsont codec for parsing incoming assistant messages from CLI *)
262
268
let incoming_jsont : t Jsont.t =
···
265
271
|> Jsont.Object.finish
266
272
267
273
let of_json json =
268
-
match Jsont.Json.decode incoming_jsont json with
269
-
| Ok v -> v
270
-
| Error msg -> raise (Invalid_argument ("Assistant.of_json: " ^ msg))
274
+
Jsont.Json.decode incoming_jsont json
275
+
|> Err.get_ok' ~msg:"Assistant.of_json: "
271
276
end
272
277
273
278
module System = struct
···
280
285
unknown : Unknown.t;
281
286
}
282
287
283
-
type error = {
284
-
error : string;
285
-
unknown : Unknown.t;
286
-
}
287
-
288
-
type other = {
289
-
subtype : string;
290
-
unknown : Unknown.t;
291
-
}
292
-
293
-
type t =
294
-
| Init of init
295
-
| Error of error
296
-
| Other of other
288
+
type error = { error : string; unknown : Unknown.t }
289
+
type other = { subtype : string; unknown : Unknown.t }
290
+
type t = Init of init | Error of error | Other of other
297
291
298
292
(* Accessors *)
299
293
let session_id = function Init i -> i.session_id | _ -> None
300
294
let model = function Init i -> i.model | _ -> None
301
295
let cwd = function Init i -> i.cwd | _ -> None
302
296
let error_msg = function Error e -> Some e.error | _ -> None
303
-
let subtype = function Init _ -> "init" | Error _ -> "error" | Other o -> o.subtype
297
+
298
+
let subtype = function
299
+
| Init _ -> "init"
300
+
| Error _ -> "error"
301
+
| Other o -> o.subtype
302
+
304
303
let unknown = function
305
304
| Init i -> i.unknown
306
305
| Error e -> e.unknown
···
310
309
let init ?session_id ?model ?cwd () =
311
310
Init { session_id; model; cwd; unknown = Unknown.empty }
312
311
313
-
let error ~error =
314
-
Error { error; unknown = Unknown.empty }
315
-
316
-
let other ~subtype =
317
-
Other { subtype; unknown = Unknown.empty }
312
+
let error ~error = Error { error; unknown = Unknown.empty }
313
+
let other ~subtype = Other { subtype; unknown = Unknown.empty }
318
314
319
315
(* Individual record codecs *)
320
316
let init_jsont : init Jsont.t =
321
-
let make session_id model cwd unknown : init = { session_id; model; cwd; unknown } in
317
+
let make session_id model cwd unknown : init =
318
+
{ session_id; model; cwd; unknown }
319
+
in
322
320
Jsont.Object.map ~kind:"SystemInit" make
323
-
|> Jsont.Object.opt_mem "session_id" Jsont.string ~enc:(fun (r : init) -> r.session_id)
324
-
|> Jsont.Object.opt_mem "model" Jsont.string ~enc:(fun (r : init) -> r.model)
321
+
|> Jsont.Object.opt_mem "session_id" Jsont.string ~enc:(fun (r : init) ->
322
+
r.session_id)
323
+
|> Jsont.Object.opt_mem "model" Jsont.string ~enc:(fun (r : init) ->
324
+
r.model)
325
325
|> Jsont.Object.opt_mem "cwd" Jsont.string ~enc:(fun (r : init) -> r.cwd)
326
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : init) -> r.unknown)
326
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : init) ->
327
+
r.unknown)
327
328
|> Jsont.Object.finish
328
329
329
330
let error_jsont : error Jsont.t =
330
331
let make err unknown : error = { error = err; unknown } in
331
332
Jsont.Object.map ~kind:"SystemError" make
332
333
|> Jsont.Object.mem "error" Jsont.string ~enc:(fun (r : error) -> r.error)
333
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : error) -> r.unknown)
334
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : error) ->
335
+
r.unknown)
334
336
|> Jsont.Object.finish
335
337
336
338
(* Main codec using case_mem for "subtype" discriminator *)
337
339
let jsont : t Jsont.t =
338
-
let case_init = Jsont.Object.Case.map "init" init_jsont ~dec:(fun v -> Init v) in
339
-
let case_error = Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v) in
340
+
let case_init =
341
+
Jsont.Object.Case.map "init" init_jsont ~dec:(fun v -> Init v)
342
+
in
343
+
let case_error =
344
+
Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
345
+
in
340
346
let case_other tag =
341
347
(* For unknown subtypes, create Other with the tag as subtype *)
342
348
let other_codec : other Jsont.t =
343
349
let make unknown : other = { subtype = tag; unknown } in
344
350
Jsont.Object.map ~kind:"SystemOther" make
345
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : other) -> r.unknown)
351
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : other) ->
352
+
r.unknown)
346
353
|> Jsont.Object.finish
347
354
in
348
355
Jsont.Object.Case.map tag other_codec ~dec:(fun v -> Other v)
···
352
359
| Error v -> Jsont.Object.Case.value case_error v
353
360
| Other v -> Jsont.Object.Case.value (case_other v.subtype) v
354
361
in
355
-
let cases = Jsont.Object.Case.[
356
-
make case_init;
357
-
make case_error;
358
-
] in
362
+
let cases = Jsont.Object.Case.[ make case_init; make case_error ] in
359
363
Jsont.Object.map ~kind:"System" Fun.id
360
364
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
361
-
~tag_to_string:Fun.id ~tag_compare:String.compare
365
+
~tag_to_string:Fun.id ~tag_compare:String.compare
362
366
|> Jsont.Object.finish
363
367
364
368
let to_json t =
365
-
match Jsont.Json.encode jsont t with
366
-
| Ok json -> json
367
-
| Error msg -> failwith ("System.to_json: " ^ msg)
369
+
Jsont.Json.encode jsont t |> Err.get_ok ~msg:"System.to_json: "
368
370
369
371
let of_json json =
370
-
match Jsont.Json.decode jsont json with
371
-
| Ok v -> v
372
-
| Error msg -> raise (Invalid_argument ("System.of_json: " ^ msg))
372
+
Jsont.Json.decode jsont json |> Err.get_ok' ~msg:"System.of_json: "
373
373
end
374
374
375
375
module Result = struct
···
383
383
unknown : Unknown.t;
384
384
}
385
385
386
-
let make input_tokens output_tokens total_tokens
387
-
cache_creation_input_tokens cache_read_input_tokens unknown =
388
-
{ input_tokens; output_tokens; total_tokens;
389
-
cache_creation_input_tokens; cache_read_input_tokens; unknown }
386
+
let make input_tokens output_tokens total_tokens cache_creation_input_tokens
387
+
cache_read_input_tokens unknown =
388
+
{
389
+
input_tokens;
390
+
output_tokens;
391
+
total_tokens;
392
+
cache_creation_input_tokens;
393
+
cache_read_input_tokens;
394
+
unknown;
395
+
}
390
396
391
397
let create ?input_tokens ?output_tokens ?total_tokens
392
-
?cache_creation_input_tokens ?cache_read_input_tokens () =
393
-
{ input_tokens; output_tokens; total_tokens;
394
-
cache_creation_input_tokens; cache_read_input_tokens;
395
-
unknown = Unknown.empty }
398
+
?cache_creation_input_tokens ?cache_read_input_tokens () =
399
+
{
400
+
input_tokens;
401
+
output_tokens;
402
+
total_tokens;
403
+
cache_creation_input_tokens;
404
+
cache_read_input_tokens;
405
+
unknown = Unknown.empty;
406
+
}
396
407
397
408
let input_tokens t = t.input_tokens
398
409
let output_tokens t = t.output_tokens
···
406
417
|> Jsont.Object.opt_mem "input_tokens" Jsont.int ~enc:input_tokens
407
418
|> Jsont.Object.opt_mem "output_tokens" Jsont.int ~enc:output_tokens
408
419
|> Jsont.Object.opt_mem "total_tokens" Jsont.int ~enc:total_tokens
409
-
|> Jsont.Object.opt_mem "cache_creation_input_tokens" Jsont.int ~enc:cache_creation_input_tokens
410
-
|> Jsont.Object.opt_mem "cache_read_input_tokens" Jsont.int ~enc:cache_read_input_tokens
420
+
|> Jsont.Object.opt_mem "cache_creation_input_tokens" Jsont.int
421
+
~enc:cache_creation_input_tokens
422
+
|> Jsont.Object.opt_mem "cache_read_input_tokens" Jsont.int
423
+
~enc:cache_read_input_tokens
411
424
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
412
425
|> Jsont.Object.finish
413
426
···
419
432
max 0 (input - cached)
420
433
421
434
let total_cost_estimate t ~input_price ~output_price =
422
-
match t.input_tokens, t.output_tokens with
435
+
match (t.input_tokens, t.output_tokens) with
423
436
| Some input, Some output ->
424
437
let input_cost = float_of_int input *. input_price /. 1_000_000. in
425
438
let output_cost = float_of_int output *. output_price /. 1_000_000. in
···
443
456
444
457
let create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
445
458
~session_id ?total_cost_usd ?usage ?result ?structured_output () =
446
-
{ subtype; duration_ms; duration_api_ms; is_error; num_turns;
447
-
session_id; total_cost_usd; usage; result; structured_output; unknown = Unknown.empty }
459
+
{
460
+
subtype;
461
+
duration_ms;
462
+
duration_api_ms;
463
+
is_error;
464
+
num_turns;
465
+
session_id;
466
+
total_cost_usd;
467
+
usage;
468
+
result;
469
+
structured_output;
470
+
unknown = Unknown.empty;
471
+
}
448
472
449
-
let make subtype duration_ms duration_api_ms is_error num_turns
450
-
session_id total_cost_usd usage result structured_output unknown =
451
-
{ subtype; duration_ms; duration_api_ms; is_error; num_turns;
452
-
session_id; total_cost_usd; usage; result; structured_output; unknown }
473
+
let make subtype duration_ms duration_api_ms is_error num_turns session_id
474
+
total_cost_usd usage result structured_output unknown =
475
+
{
476
+
subtype;
477
+
duration_ms;
478
+
duration_api_ms;
479
+
is_error;
480
+
num_turns;
481
+
session_id;
482
+
total_cost_usd;
483
+
usage;
484
+
result;
485
+
structured_output;
486
+
unknown;
487
+
}
453
488
454
489
let subtype t = t.subtype
455
490
let duration_ms t = t.duration_ms
···
474
509
|> Jsont.Object.opt_mem "total_cost_usd" Jsont.number ~enc:total_cost_usd
475
510
|> Jsont.Object.opt_mem "usage" Usage.jsont ~enc:usage
476
511
|> Jsont.Object.opt_mem "result" Jsont.string ~enc:result
477
-
|> Jsont.Object.opt_mem "structured_output" Jsont.json ~enc:structured_output
512
+
|> Jsont.Object.opt_mem "structured_output" Jsont.json
513
+
~enc:structured_output
478
514
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
479
515
|> Jsont.Object.finish
480
516
···
496
532
497
533
let jsont : wire Jsont.t =
498
534
let make type_ subtype duration_ms duration_api_ms is_error num_turns
499
-
session_id total_cost_usd usage result structured_output =
500
-
{ type_; subtype; duration_ms; duration_api_ms; is_error; num_turns;
501
-
session_id; total_cost_usd; usage; result; structured_output }
535
+
session_id total_cost_usd usage result structured_output =
536
+
{
537
+
type_;
538
+
subtype;
539
+
duration_ms;
540
+
duration_api_ms;
541
+
is_error;
542
+
num_turns;
543
+
session_id;
544
+
total_cost_usd;
545
+
usage;
546
+
result;
547
+
structured_output;
548
+
}
502
549
in
503
550
Jsont.Object.map ~kind:"ResultWire" make
504
551
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun r -> r.type_)
505
552
|> Jsont.Object.mem "subtype" Jsont.string ~enc:(fun r -> r.subtype)
506
553
|> Jsont.Object.mem "duration_ms" Jsont.int ~enc:(fun r -> r.duration_ms)
507
-
|> Jsont.Object.mem "duration_api_ms" Jsont.int ~enc:(fun r -> r.duration_api_ms)
554
+
|> Jsont.Object.mem "duration_api_ms" Jsont.int ~enc:(fun r ->
555
+
r.duration_api_ms)
508
556
|> Jsont.Object.mem "is_error" Jsont.bool ~enc:(fun r -> r.is_error)
509
557
|> Jsont.Object.mem "num_turns" Jsont.int ~enc:(fun r -> r.num_turns)
510
558
|> Jsont.Object.mem "session_id" Jsont.string ~enc:(fun r -> r.session_id)
511
-
|> Jsont.Object.opt_mem "total_cost_usd" Jsont.number ~enc:(fun r -> r.total_cost_usd)
559
+
|> Jsont.Object.opt_mem "total_cost_usd" Jsont.number ~enc:(fun r ->
560
+
r.total_cost_usd)
512
561
|> Jsont.Object.opt_mem "usage" Jsont.json ~enc:(fun r -> r.usage)
513
562
|> Jsont.Object.opt_mem "result" Jsont.string ~enc:(fun r -> r.result)
514
-
|> Jsont.Object.opt_mem "structured_output" Jsont.json ~enc:(fun r -> r.structured_output)
563
+
|> Jsont.Object.opt_mem "structured_output" Jsont.json ~enc:(fun r ->
564
+
r.structured_output)
515
565
|> Jsont.Object.finish
516
566
end
517
567
518
568
let to_json t =
519
-
let usage_json = Option.map (fun u ->
520
-
match Jsont.Json.encode Usage.jsont u with
521
-
| Ok j -> j
522
-
| Error msg -> failwith ("Result.to_json: usage: " ^ msg)
523
-
) t.usage in
524
-
let wire = Wire.{
525
-
type_ = "result";
526
-
subtype = t.subtype;
527
-
duration_ms = t.duration_ms;
528
-
duration_api_ms = t.duration_api_ms;
529
-
is_error = t.is_error;
530
-
num_turns = t.num_turns;
531
-
session_id = t.session_id;
532
-
total_cost_usd = t.total_cost_usd;
533
-
usage = usage_json;
534
-
result = t.result;
535
-
structured_output = t.structured_output;
536
-
} in
537
-
match Jsont.Json.encode Wire.jsont wire with
538
-
| Ok json -> json
539
-
| Error msg -> failwith ("Result.to_json: " ^ msg)
569
+
let usage_json =
570
+
t.usage
571
+
|> Option.map (fun u ->
572
+
Jsont.Json.encode Usage.jsont u
573
+
|> Err.get_ok ~msg:"Result.to_json: usage: ")
574
+
in
575
+
let wire =
576
+
Wire.
577
+
{
578
+
type_ = "result";
579
+
subtype = t.subtype;
580
+
duration_ms = t.duration_ms;
581
+
duration_api_ms = t.duration_api_ms;
582
+
is_error = t.is_error;
583
+
num_turns = t.num_turns;
584
+
session_id = t.session_id;
585
+
total_cost_usd = t.total_cost_usd;
586
+
usage = usage_json;
587
+
result = t.result;
588
+
structured_output = t.structured_output;
589
+
}
590
+
in
591
+
Jsont.Json.encode Wire.jsont wire |> Err.get_ok ~msg:"Result.to_json: "
540
592
541
593
let of_json json =
542
-
match Jsont.Json.decode jsont json with
543
-
| Ok v -> v
544
-
| Error msg -> raise (Invalid_argument ("Result.of_json: " ^ msg))
594
+
Jsont.Json.decode jsont json |> Err.get_ok' ~msg:"Result.of_json: "
545
595
end
546
596
547
597
type t =
···
552
602
553
603
let user_string s = User (User.create_string s)
554
604
let user_blocks blocks = User (User.create_blocks blocks)
605
+
555
606
let user_with_tool_result ~tool_use_id ~content ?is_error () =
556
607
User (User.create_with_tool_result ~tool_use_id ~content ?is_error ())
557
608
558
-
let assistant ~content ~model ?error () = Assistant (Assistant.create ~content ~model ?error ())
609
+
let assistant ~content ~model ?error () =
610
+
Assistant (Assistant.create ~content ~model ?error ())
611
+
559
612
let assistant_text ~text ~model ?error () =
560
-
Assistant (Assistant.create ~content:[Content_block.text text] ~model ?error ())
613
+
Assistant
614
+
(Assistant.create ~content:[ Content_block.text text ] ~model ?error ())
561
615
562
-
let system_init ~session_id =
563
-
System (System.init ~session_id ())
564
-
let system_error ~error =
565
-
System (System.error ~error)
616
+
let system_init ~session_id = System (System.init ~session_id ())
617
+
let system_error ~error = System (System.error ~error)
566
618
567
619
let result ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
568
620
~session_id ?total_cost_usd ?usage ?result ?structured_output () =
569
-
Result (Result.create ~subtype ~duration_ms ~duration_api_ms ~is_error
570
-
~num_turns ~session_id ?total_cost_usd ?usage ?result ?structured_output ())
621
+
Result
622
+
(Result.create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
623
+
~session_id ?total_cost_usd ?usage ?result ?structured_output ())
571
624
572
625
let to_json = function
573
626
| User t -> User.to_json t
···
580
633
let jsont : t Jsont.t =
581
634
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
582
635
let case_user = case_map "user" User.incoming_jsont (fun v -> User v) in
583
-
let case_assistant = case_map "assistant" Assistant.incoming_jsont (fun v -> Assistant v) in
636
+
let case_assistant =
637
+
case_map "assistant" Assistant.incoming_jsont (fun v -> Assistant v)
638
+
in
584
639
let case_system = case_map "system" System.jsont (fun v -> System v) in
585
640
let case_result = case_map "result" Result.jsont (fun v -> Result v) in
586
641
let enc_case = function
···
589
644
| System v -> Jsont.Object.Case.value case_system v
590
645
| Result v -> Jsont.Object.Case.value case_result v
591
646
in
592
-
let cases = Jsont.Object.Case.[
593
-
make case_user;
594
-
make case_assistant;
595
-
make case_system;
596
-
make case_result
597
-
] in
647
+
let cases =
648
+
Jsont.Object.Case.
649
+
[
650
+
make case_user; make case_assistant; make case_system; make case_result;
651
+
]
652
+
in
598
653
Jsont.Object.map ~kind:"Message" Fun.id
599
654
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
600
-
~tag_to_string:Fun.id ~tag_compare:String.compare
655
+
~tag_to_string:Fun.id ~tag_compare:String.compare
601
656
|> Jsont.Object.finish
602
657
603
658
let of_json json =
604
-
match Jsont.Json.decode jsont json with
605
-
| Ok v -> v
606
-
| Error msg -> raise (Invalid_argument ("Message.of_json: " ^ msg))
659
+
Jsont.Json.decode jsont json |> Err.get_ok' ~msg:"Message.of_json: "
607
660
608
661
let is_user = function User _ -> true | _ -> false
609
662
let is_assistant = function Assistant _ -> true | _ -> false
···
617
670
618
671
let extract_text = function
619
672
| User u -> User.as_text u
620
-
| Assistant a ->
673
+
| Assistant a ->
621
674
let text = Assistant.combined_text a in
622
675
if text = "" then None else Some text
623
676
| _ -> None
···
632
685
| _ -> None
633
686
634
687
let pp = Jsont.pp_value jsont ()
635
-
636
-
let log_received t =
637
-
Log.info (fun m -> m "← %a" pp t)
638
-
639
-
let log_sending t =
640
-
Log.info (fun m -> m "→ %a" pp t)
641
-
642
-
let log_error msg t =
643
-
Log.err (fun m -> m "%s: %a" msg pp t)
644
-
688
+
let log_received t = Log.info (fun m -> m "← %a" pp t)
689
+
let log_sending t = Log.info (fun m -> m "→ %a" pp t)
690
+
let log_error msg t = Log.err (fun m -> m "%s: %a" msg pp t)
+70
-56
lib/message.mli
+70
-56
lib/message.mli
···
4
4
received from Claude, including user input, assistant responses, system
5
5
messages, and result metadata. *)
6
6
7
-
(** The log source for message operations *)
8
7
val src : Logs.Src.t
8
+
(** The log source for message operations *)
9
9
10
10
(** {1 User Messages} *)
11
11
12
12
module User : sig
13
13
(** Messages sent by the user. *)
14
14
15
+
(** The content of a user message. *)
15
16
type content =
16
17
| String of string (** Simple text message *)
17
-
| Blocks of Content_block.t list (** Complex message with multiple content blocks *)
18
-
(** The content of a user message. *)
18
+
| Blocks of Content_block.t list
19
+
(** Complex message with multiple content blocks *)
19
20
20
21
type t
21
22
(** The type of user messages. *)
···
30
31
(** [create_blocks blocks] creates a user message with content blocks. *)
31
32
32
33
val create_with_tool_result :
33
-
tool_use_id:string ->
34
-
content:string ->
35
-
?is_error:bool ->
36
-
unit -> t
37
-
(** [create_with_tool_result ~tool_use_id ~content ?is_error ()] creates a user
38
-
message containing a tool result. *)
34
+
tool_use_id:string -> content:string -> ?is_error:bool -> unit -> t
35
+
(** [create_with_tool_result ~tool_use_id ~content ?is_error ()] creates a
36
+
user message containing a tool result. *)
39
37
40
-
val create_mixed : text:string option -> tool_results:(string * string * bool option) list -> t
41
-
(** [create_mixed ?text ~tool_results] creates a user message with optional text
42
-
and tool results. Each tool result is (tool_use_id, content, is_error). *)
38
+
val create_mixed :
39
+
text:string option -> tool_results:(string * string * bool option) list -> t
40
+
(** [create_mixed ?text ~tool_results] creates a user message with optional
41
+
text and tool results. Each tool result is (tool_use_id, content,
42
+
is_error). *)
43
43
44
44
val content : t -> content
45
45
(** [content t] returns the content of the user message. *)
···
48
48
(** [unknown t] returns the unknown fields preserved from JSON. *)
49
49
50
50
val as_text : t -> string option
51
-
(** [as_text t] returns the text content if the message is a simple string, None otherwise. *)
51
+
(** [as_text t] returns the text content if the message is a simple string,
52
+
None otherwise. *)
52
53
53
54
val get_blocks : t -> Content_block.t list
54
-
(** [get_blocks t] returns the content blocks, or a single text block if it's a string message. *)
55
+
(** [get_blocks t] returns the content blocks, or a single text block if it's
56
+
a string message. *)
55
57
56
58
val to_json : t -> Jsont.json
57
59
(** [to_json t] converts the user message to its JSON representation. *)
···
66
68
module Assistant : sig
67
69
(** Messages from Claude assistant. *)
68
70
69
-
type error = [
70
-
| `Authentication_failed (** Authentication with Claude API failed *)
71
-
| `Billing_error (** Billing or account issue *)
72
-
| `Rate_limit (** Rate limit exceeded *)
73
-
| `Invalid_request (** Request was invalid *)
74
-
| `Server_error (** Internal server error *)
75
-
| `Unknown (** Unknown error type *)
76
-
]
71
+
type error =
72
+
[ `Authentication_failed (** Authentication with Claude API failed *)
73
+
| `Billing_error (** Billing or account issue *)
74
+
| `Rate_limit (** Rate limit exceeded *)
75
+
| `Invalid_request (** Request was invalid *)
76
+
| `Server_error (** Internal server error *)
77
+
| `Unknown (** Unknown error type *) ]
77
78
(** The type of assistant message errors based on Python SDK error types. *)
78
79
79
80
val error_to_string : error -> string
80
81
(** [error_to_string err] converts an error to its string representation. *)
81
82
82
83
val error_of_string : string -> error
83
-
(** [error_of_string s] parses an error string. Unknown strings become [`Unknown]. *)
84
+
(** [error_of_string s] parses an error string. Unknown strings become
85
+
[`Unknown]. *)
84
86
85
87
type t
86
88
(** The type of assistant messages. *)
···
88
90
val jsont : t Jsont.t
89
91
(** [jsont] is the Jsont codec for assistant messages. *)
90
92
91
-
val create : content:Content_block.t list -> model:string -> ?error:error -> unit -> t
93
+
val create :
94
+
content:Content_block.t list -> model:string -> ?error:error -> unit -> t
92
95
(** [create ~content ~model ?error ()] creates an assistant message.
93
96
@param content List of content blocks in the response
94
97
@param model The model identifier used for the response
···
101
104
(** [model t] returns the model identifier. *)
102
105
103
106
val error : t -> error option
104
-
(** [error t] returns the optional error that occurred during message generation. *)
107
+
(** [error t] returns the optional error that occurred during message
108
+
generation. *)
105
109
106
110
val unknown : t -> Unknown.t
107
111
(** [unknown t] returns the unknown fields preserved from JSON. *)
···
116
120
(** [get_thinking t] extracts all thinking blocks from the message. *)
117
121
118
122
val has_tool_use : t -> bool
119
-
(** [has_tool_use t] returns true if the message contains any tool use blocks. *)
123
+
(** [has_tool_use t] returns true if the message contains any tool use blocks.
124
+
*)
120
125
121
126
val combined_text : t -> string
122
127
(** [combined_text t] concatenates all text blocks into a single string. *)
···
147
152
}
148
153
(** Init message fields. *)
149
154
150
-
type error = {
151
-
error : string;
152
-
unknown : Unknown.t;
153
-
}
155
+
type error = { error : string; unknown : Unknown.t }
154
156
(** Error message fields. *)
155
157
156
-
type other = {
157
-
subtype : string;
158
-
unknown : Unknown.t;
159
-
}
158
+
type other = { subtype : string; unknown : Unknown.t }
160
159
(** Unknown subtype fields. *)
161
160
162
161
type t =
163
162
| Init of init
164
163
| Error of error
165
-
| Other of other
166
-
(** The type of system messages. *)
164
+
| Other of other (** The type of system messages. *)
167
165
168
166
val jsont : t Jsont.t
169
167
(** [jsont] is the Jsont codec for system messages. *)
···
229
227
?total_tokens:int ->
230
228
?cache_creation_input_tokens:int ->
231
229
?cache_read_input_tokens:int ->
232
-
unit -> t
233
-
(** [create ?input_tokens ?output_tokens ?total_tokens ?cache_creation_input_tokens
234
-
?cache_read_input_tokens ()] creates usage statistics. *)
230
+
unit ->
231
+
t
232
+
(** [create ?input_tokens ?output_tokens ?total_tokens
233
+
?cache_creation_input_tokens ?cache_read_input_tokens ()] creates usage
234
+
statistics. *)
235
235
236
236
val input_tokens : t -> int option
237
237
(** [input_tokens t] returns the number of input tokens used. *)
···
252
252
(** [unknown t] returns the unknown fields preserved from JSON. *)
253
253
254
254
val effective_input_tokens : t -> int
255
-
(** [effective_input_tokens t] returns input tokens minus cached tokens, or 0 if not available. *)
255
+
(** [effective_input_tokens t] returns input tokens minus cached tokens, or
256
+
0 if not available. *)
256
257
257
-
val total_cost_estimate : t -> input_price:float -> output_price:float -> float option
258
-
(** [total_cost_estimate t ~input_price ~output_price] estimates the cost based on token
259
-
prices per million tokens. Returns None if token counts are not available. *)
258
+
val total_cost_estimate :
259
+
t -> input_price:float -> output_price:float -> float option
260
+
(** [total_cost_estimate t ~input_price ~output_price] estimates the cost
261
+
based on token prices per million tokens. Returns None if token counts
262
+
are not available. *)
260
263
end
261
264
262
265
type t
···
276
279
?usage:Usage.t ->
277
280
?result:string ->
278
281
?structured_output:Jsont.json ->
279
-
unit -> t
282
+
unit ->
283
+
t
280
284
(** [create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
281
-
~session_id ?total_cost_usd ?usage ?result ()] creates a result message.
285
+
~session_id ?total_cost_usd ?usage ?result ()] creates a result message.
282
286
@param subtype The subtype of the result
283
287
@param duration_ms Total duration in milliseconds
284
288
@param duration_api_ms API duration in milliseconds
···
338
342
| Assistant of Assistant.t
339
343
| System of System.t
340
344
| Result of Result.t
341
-
(** The type of messages, which can be user, assistant, system, or result. *)
345
+
(** The type of messages, which can be user, assistant, system, or result.
346
+
*)
342
347
343
348
val jsont : t Jsont.t
344
349
(** [jsont] is the Jsont codec for messages. *)
···
349
354
val user_blocks : Content_block.t list -> t
350
355
(** [user_blocks blocks] creates a user message with content blocks. *)
351
356
352
-
val user_with_tool_result : tool_use_id:string -> content:string -> ?is_error:bool -> unit -> t
353
-
(** [user_with_tool_result ~tool_use_id ~content ?is_error ()] creates a user message
354
-
containing a tool result. *)
357
+
val user_with_tool_result :
358
+
tool_use_id:string -> content:string -> ?is_error:bool -> unit -> t
359
+
(** [user_with_tool_result ~tool_use_id ~content ?is_error ()] creates a user
360
+
message containing a tool result. *)
355
361
356
-
val assistant : content:Content_block.t list -> model:string -> ?error:Assistant.error -> unit -> t
362
+
val assistant :
363
+
content:Content_block.t list ->
364
+
model:string ->
365
+
?error:Assistant.error ->
366
+
unit ->
367
+
t
357
368
(** [assistant ~content ~model ?error ()] creates an assistant message. *)
358
369
359
-
val assistant_text : text:string -> model:string -> ?error:Assistant.error -> unit -> t
360
-
(** [assistant_text ~text ~model ?error ()] creates an assistant message with only text content. *)
370
+
val assistant_text :
371
+
text:string -> model:string -> ?error:Assistant.error -> unit -> t
372
+
(** [assistant_text ~text ~model ?error ()] creates an assistant message with
373
+
only text content. *)
361
374
362
375
val system_init : session_id:string -> t
363
376
(** [system_init ~session_id] creates a system init message. *)
···
376
389
?usage:Result.Usage.t ->
377
390
?result:string ->
378
391
?structured_output:Jsont.json ->
379
-
unit -> t
392
+
unit ->
393
+
t
380
394
(** [result ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
381
-
~session_id ?total_cost_usd ?usage ?result ()] creates a result message. *)
395
+
~session_id ?total_cost_usd ?usage ?result ()] creates a result message. *)
382
396
383
397
val to_json : t -> Jsont.json
384
398
(** [to_json t] converts any message to its JSON representation. *)
···
414
428
(** [extract_tool_uses t] extracts tool use blocks from assistant messages. *)
415
429
416
430
val get_session_id : t -> string option
417
-
(** [get_session_id t] extracts the session ID from system or result messages. *)
431
+
(** [get_session_id t] extracts the session ID from system or result messages.
432
+
*)
418
433
419
434
(** {1 Logging} *)
420
435
···
426
441
427
442
val log_error : string -> t -> unit
428
443
(** [log_error msg t] logs an error with the given message and context. *)
429
-
+3
-4
lib/model.ml
+3
-4
lib/model.ml
+9
-10
lib/model.mli
+9
-10
lib/model.mli
···
4
4
model strings. Use polymorphic variants for known models with a custom
5
5
escape hatch for future or unknown models. *)
6
6
7
-
type t = [
8
-
| `Sonnet_4_5 (** claude-sonnet-4-5 - Most recent Sonnet model *)
9
-
| `Sonnet_4 (** claude-sonnet-4 - Sonnet 4 model *)
10
-
| `Sonnet_3_5 (** claude-sonnet-3-5 - Sonnet 3.5 model *)
11
-
| `Opus_4 (** claude-opus-4 - Opus 4 model for complex tasks *)
12
-
| `Haiku_4 (** claude-haiku-4 - Fast, cost-effective Haiku model *)
13
-
| `Custom of string (** Custom model string for future/unknown models *)
14
-
]
7
+
type t =
8
+
[ `Sonnet_4_5 (** claude-sonnet-4-5 - Most recent Sonnet model *)
9
+
| `Sonnet_4 (** claude-sonnet-4 - Sonnet 4 model *)
10
+
| `Sonnet_3_5 (** claude-sonnet-3-5 - Sonnet 3.5 model *)
11
+
| `Opus_4 (** claude-opus-4 - Opus 4 model for complex tasks *)
12
+
| `Haiku_4 (** claude-haiku-4 - Fast, cost-effective Haiku model *)
13
+
| `Custom of string (** Custom model string for future/unknown models *) ]
15
14
(** The type of Claude models. *)
16
15
17
16
val to_string : t -> string
···
25
24
val of_string : string -> t
26
25
(** [of_string s] parses a model string into a typed model.
27
26
28
-
Known model strings are converted to their typed variants.
29
-
Unknown strings become [`Custom s].
27
+
Known model strings are converted to their typed variants. Unknown strings
28
+
become [`Custom s].
30
29
31
30
Examples:
32
31
- "claude-sonnet-4-5" becomes [`Sonnet_4_5]
+126
-112
lib/options.ml
+126
-112
lib/options.ml
···
1
1
let src = Logs.Src.create "claude.options" ~doc:"Claude configuration options"
2
+
2
3
module Log = (val Logs.src_log src : Logs.LOG)
3
4
4
5
type setting_source = User | Project | Local
···
32
33
unknown : Unknown.t;
33
34
}
34
35
35
-
let default = {
36
-
allowed_tools = [];
37
-
disallowed_tools = [];
38
-
max_thinking_tokens = 8000;
39
-
system_prompt = None;
40
-
append_system_prompt = None;
41
-
permission_mode = None;
42
-
permission_callback = Some Permissions.default_allow_callback;
43
-
model = None;
44
-
cwd = None;
45
-
env = [];
46
-
continue_conversation = false;
47
-
resume = None;
48
-
max_turns = None;
49
-
permission_prompt_tool_name = None;
50
-
settings = None;
51
-
add_dirs = [];
52
-
extra_args = [];
53
-
debug_stderr = None;
54
-
hooks = None;
55
-
max_budget_usd = None;
56
-
fallback_model = None;
57
-
setting_sources = None;
58
-
max_buffer_size = None;
59
-
user = None;
60
-
output_format = None;
61
-
unknown = Unknown.empty;
62
-
}
36
+
let default =
37
+
{
38
+
allowed_tools = [];
39
+
disallowed_tools = [];
40
+
max_thinking_tokens = 8000;
41
+
system_prompt = None;
42
+
append_system_prompt = None;
43
+
permission_mode = None;
44
+
permission_callback = Some Permissions.default_allow_callback;
45
+
model = None;
46
+
cwd = None;
47
+
env = [];
48
+
continue_conversation = false;
49
+
resume = None;
50
+
max_turns = None;
51
+
permission_prompt_tool_name = None;
52
+
settings = None;
53
+
add_dirs = [];
54
+
extra_args = [];
55
+
debug_stderr = None;
56
+
hooks = None;
57
+
max_budget_usd = None;
58
+
fallback_model = None;
59
+
setting_sources = None;
60
+
max_buffer_size = None;
61
+
user = None;
62
+
output_format = None;
63
+
unknown = Unknown.empty;
64
+
}
63
65
64
-
let create
65
-
?(allowed_tools = [])
66
-
?(disallowed_tools = [])
67
-
?(max_thinking_tokens = 8000)
68
-
?system_prompt
69
-
?append_system_prompt
70
-
?permission_mode
71
-
?permission_callback
72
-
?model
73
-
?cwd
74
-
?(env = [])
75
-
?(continue_conversation = false)
76
-
?resume
77
-
?max_turns
78
-
?permission_prompt_tool_name
79
-
?settings
80
-
?(add_dirs = [])
81
-
?(extra_args = [])
82
-
?debug_stderr
83
-
?hooks
84
-
?max_budget_usd
85
-
?fallback_model
86
-
?setting_sources
87
-
?max_buffer_size
88
-
?user
89
-
?output_format
90
-
?(unknown = Unknown.empty)
91
-
() =
92
-
{ allowed_tools; disallowed_tools; max_thinking_tokens;
93
-
system_prompt; append_system_prompt; permission_mode;
94
-
permission_callback; model; cwd; env;
95
-
continue_conversation; resume; max_turns;
96
-
permission_prompt_tool_name; settings; add_dirs;
97
-
extra_args; debug_stderr; hooks;
98
-
max_budget_usd; fallback_model; setting_sources;
99
-
max_buffer_size; user; output_format; unknown }
66
+
let create ?(allowed_tools = []) ?(disallowed_tools = [])
67
+
?(max_thinking_tokens = 8000) ?system_prompt ?append_system_prompt
68
+
?permission_mode ?permission_callback ?model ?cwd ?(env = [])
69
+
?(continue_conversation = false) ?resume ?max_turns
70
+
?permission_prompt_tool_name ?settings ?(add_dirs = []) ?(extra_args = [])
71
+
?debug_stderr ?hooks ?max_budget_usd ?fallback_model ?setting_sources
72
+
?max_buffer_size ?user ?output_format ?(unknown = Unknown.empty) () =
73
+
{
74
+
allowed_tools;
75
+
disallowed_tools;
76
+
max_thinking_tokens;
77
+
system_prompt;
78
+
append_system_prompt;
79
+
permission_mode;
80
+
permission_callback;
81
+
model;
82
+
cwd;
83
+
env;
84
+
continue_conversation;
85
+
resume;
86
+
max_turns;
87
+
permission_prompt_tool_name;
88
+
settings;
89
+
add_dirs;
90
+
extra_args;
91
+
debug_stderr;
92
+
hooks;
93
+
max_budget_usd;
94
+
fallback_model;
95
+
setting_sources;
96
+
max_buffer_size;
97
+
user;
98
+
output_format;
99
+
unknown;
100
+
}
100
101
101
102
let allowed_tools t = t.allowed_tools
102
103
let disallowed_tools t = t.disallowed_tools
···
124
125
let user t = t.user
125
126
let output_format t = t.output_format
126
127
let unknown t = t.unknown
127
-
128
128
let with_allowed_tools tools t = { t with allowed_tools = tools }
129
129
let with_disallowed_tools tools t = { t with disallowed_tools = tools }
130
130
let with_max_thinking_tokens tokens t = { t with max_thinking_tokens = tokens }
131
131
let with_system_prompt prompt t = { t with system_prompt = Some prompt }
132
-
let with_append_system_prompt prompt t = { t with append_system_prompt = Some prompt }
132
+
133
+
let with_append_system_prompt prompt t =
134
+
{ t with append_system_prompt = Some prompt }
135
+
133
136
let with_permission_mode mode t = { t with permission_mode = Some mode }
134
-
let with_permission_callback callback t = { t with permission_callback = Some callback }
137
+
138
+
let with_permission_callback callback t =
139
+
{ t with permission_callback = Some callback }
140
+
135
141
let with_model model t = { t with model = Some model }
136
142
let with_model_string model t = { t with model = Some (Model.of_string model) }
137
143
let with_cwd cwd t = { t with cwd = Some cwd }
138
144
let with_env env t = { t with env }
139
-
let with_continue_conversation continue t = { t with continue_conversation = continue }
145
+
146
+
let with_continue_conversation continue t =
147
+
{ t with continue_conversation = continue }
148
+
140
149
let with_resume session_id t = { t with resume = Some session_id }
141
150
let with_max_turns turns t = { t with max_turns = Some turns }
142
-
let with_permission_prompt_tool_name tool t = { t with permission_prompt_tool_name = Some tool }
151
+
152
+
let with_permission_prompt_tool_name tool t =
153
+
{ t with permission_prompt_tool_name = Some tool }
154
+
143
155
let with_settings path t = { t with settings = Some path }
144
156
let with_add_dirs dirs t = { t with add_dirs = dirs }
145
157
let with_extra_args args t = { t with extra_args = args }
···
147
159
let with_hooks hooks t = { t with hooks = Some hooks }
148
160
let with_max_budget_usd budget t = { t with max_budget_usd = Some budget }
149
161
let with_fallback_model model t = { t with fallback_model = Some model }
150
-
let with_fallback_model_string model t = { t with fallback_model = Some (Model.of_string model) }
162
+
163
+
let with_fallback_model_string model t =
164
+
{ t with fallback_model = Some (Model.of_string model) }
165
+
151
166
let with_setting_sources sources t = { t with setting_sources = Some sources }
152
167
let with_no_settings t = { t with setting_sources = Some [] }
153
168
let with_max_buffer_size size t = { t with max_buffer_size = Some size }
···
156
171
157
172
(* Helper codec for Model.t *)
158
173
let model_jsont : Model.t Jsont.t =
159
-
Jsont.map ~kind:"Model"
160
-
~dec:Model.of_string
161
-
~enc:Model.to_string
162
-
Jsont.string
174
+
Jsont.map ~kind:"Model" ~dec:Model.of_string ~enc:Model.to_string Jsont.string
163
175
164
176
(* Helper codec for env - list of string pairs encoded as object.
165
177
Env is a dynamic object where all values should be strings.
···
169
181
~dec:(fun json ->
170
182
match json with
171
183
| Jsont.Object (members, _) ->
172
-
List.filter_map (fun ((name, _), value) ->
173
-
match Jsont.Json.decode Jsont.string value with
174
-
| Ok s -> Some (name, s)
175
-
| Error _ -> None
176
-
) members
184
+
List.filter_map
185
+
(fun ((name, _), value) ->
186
+
match Jsont.Json.decode Jsont.string value with
187
+
| Ok s -> Some (name, s)
188
+
| Error _ -> None)
189
+
members
177
190
| _ -> [])
178
191
~enc:(fun pairs ->
179
-
Jsont.Json.object' (List.map (fun (k, v) ->
180
-
Jsont.Json.mem (Jsont.Json.name k) (Jsont.Json.string v)
181
-
) pairs))
192
+
Jsont.Json.object'
193
+
(List.map
194
+
(fun (k, v) ->
195
+
Jsont.Json.mem (Jsont.Json.name k) (Jsont.Json.string v))
196
+
pairs))
182
197
Jsont.json
183
198
184
199
let jsont : t Jsont.t =
185
-
let make allowed_tools disallowed_tools max_thinking_tokens
186
-
system_prompt append_system_prompt permission_mode
187
-
model env unknown =
188
-
{ allowed_tools; disallowed_tools; max_thinking_tokens;
189
-
system_prompt; append_system_prompt; permission_mode;
200
+
let make allowed_tools disallowed_tools max_thinking_tokens system_prompt
201
+
append_system_prompt permission_mode model env unknown =
202
+
{
203
+
allowed_tools;
204
+
disallowed_tools;
205
+
max_thinking_tokens;
206
+
system_prompt;
207
+
append_system_prompt;
208
+
permission_mode;
190
209
permission_callback = Some Permissions.default_allow_callback;
191
-
model; cwd = None; env;
210
+
model;
211
+
cwd = None;
212
+
env;
192
213
continue_conversation = false;
193
214
resume = None;
194
215
max_turns = None;
···
204
225
max_buffer_size = None;
205
226
user = None;
206
227
output_format = None;
207
-
unknown }
228
+
unknown;
229
+
}
208
230
in
209
-
Jsont.Object.map ~kind:"Options" make
210
-
|> Jsont.Object.mem "allowed_tools" (Jsont.list Jsont.string) ~enc:allowed_tools ~dec_absent:[]
211
-
|> Jsont.Object.mem "disallowed_tools" (Jsont.list Jsont.string) ~enc:disallowed_tools ~dec_absent:[]
212
-
|> Jsont.Object.mem "max_thinking_tokens" Jsont.int ~enc:max_thinking_tokens ~dec_absent:8000
213
-
|> Jsont.Object.opt_mem "system_prompt" Jsont.string ~enc:system_prompt
214
-
|> Jsont.Object.opt_mem "append_system_prompt" Jsont.string ~enc:append_system_prompt
215
-
|> Jsont.Object.opt_mem "permission_mode" Permissions.Mode.jsont ~enc:permission_mode
216
-
|> Jsont.Object.opt_mem "model" model_jsont ~enc:model
217
-
|> Jsont.Object.mem "env" env_jsont ~enc:env ~dec_absent:[]
218
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
219
-
|> Jsont.Object.finish
220
-
221
-
(*
222
-
let to_json t =
223
-
match Jsont.Json.encode jsont t with
224
-
| Ok json -> json
225
-
| Error msg -> failwith ("Options.to_json: " ^ msg)
226
-
227
-
let of_json json =
228
-
match Jsont.Json.decode jsont json with
229
-
| Ok t -> t
230
-
| Error msg -> raise (Invalid_argument ("Options.of_json: " ^ msg))
231
-
*)
231
+
Jsont.Object.(
232
+
map ~kind:"Options" make
233
+
|> mem "allowed_tools" (Jsont.list Jsont.string) ~enc:allowed_tools
234
+
~dec_absent:[]
235
+
|> mem "disallowed_tools" (Jsont.list Jsont.string) ~enc:disallowed_tools
236
+
~dec_absent:[]
237
+
|> mem "max_thinking_tokens" Jsont.int ~enc:max_thinking_tokens
238
+
~dec_absent:8000
239
+
|> opt_mem "system_prompt" Jsont.string ~enc:system_prompt
240
+
|> opt_mem "append_system_prompt" Jsont.string ~enc:append_system_prompt
241
+
|> opt_mem "permission_mode" Permissions.Mode.jsont ~enc:permission_mode
242
+
|> opt_mem "model" model_jsont ~enc:model
243
+
|> mem "env" env_jsont ~enc:env ~dec_absent:[]
244
+
|> keep_unknown Jsont.json_mems ~enc:unknown
245
+
|> finish)
232
246
233
247
let log_options t =
234
248
Log.debug (fun m -> m "Claude options: %a" (Jsont.pp_value jsont ()) t)
+73
-51
lib/options.mli
+73
-51
lib/options.mli
···
17
17
18
18
{2 Builder Pattern}
19
19
20
-
Options use a functional builder pattern - each [with_*] function returns
21
-
a new options value with the specified field updated:
20
+
Options use a functional builder pattern - each [with_*] function returns a
21
+
new options value with the specified field updated:
22
22
23
23
{[
24
-
let options = Options.default
24
+
let options =
25
+
Options.default
25
26
|> Options.with_model "claude-sonnet-4-5"
26
27
|> Options.with_max_budget_usd 1.0
27
28
|> Options.with_permission_mode Permissions.Mode.Accept_edits
···
32
33
{3 CI/CD: Isolated, Reproducible Builds}
33
34
34
35
{[
35
-
let ci_config = Options.default
36
-
|> Options.with_no_settings (* Ignore user config *)
37
-
|> Options.with_max_budget_usd 0.50 (* 50 cent limit *)
38
-
|> Options.with_permission_mode
39
-
Permissions.Mode.Bypass_permissions
36
+
let ci_config =
37
+
Options.default |> Options.with_no_settings (* Ignore user config *)
38
+
|> Options.with_max_budget_usd 0.50 (* 50 cent limit *)
39
+
|> Options.with_permission_mode Permissions.Mode.Bypass_permissions
40
40
|> Options.with_model "claude-haiku-4"
41
41
]}
42
42
43
43
{3 Production: Cost Control with Fallback}
44
44
45
45
{[
46
-
let prod_config = Options.default
46
+
let prod_config =
47
+
Options.default
47
48
|> Options.with_model "claude-sonnet-4-5"
48
49
|> Options.with_fallback_model "claude-haiku-4"
49
-
|> Options.with_max_budget_usd 10.0 (* $10 daily limit *)
50
+
|> Options.with_max_budget_usd 10.0 (* $10 daily limit *)
50
51
|> Options.with_max_buffer_size 5_000_000
51
52
]}
52
53
53
54
{3 Development: User Settings with Overrides}
54
55
55
56
{[
56
-
let dev_config = Options.default
57
-
|> Options.with_setting_sources [User; Project]
57
+
let dev_config =
58
+
Options.default
59
+
|> Options.with_setting_sources [ User; Project ]
58
60
|> Options.with_max_budget_usd 1.0
59
61
|> Options.with_permission_mode Permissions.Mode.Default
60
62
]}
···
62
64
{3 Structured Output: Type-Safe Responses}
63
65
64
66
{[
65
-
let schema = Jsont.json_of_json (`O [
66
-
("type", `String "object");
67
-
("properties", `O [
68
-
("count", `O [("type", `String "integer")]);
69
-
("has_tests", `O [("type", `String "boolean")]);
70
-
]);
71
-
])
67
+
let schema =
68
+
Jsont.json_of_json
69
+
(`O
70
+
[
71
+
("type", `String "object");
72
+
( "properties",
73
+
`O
74
+
[
75
+
("count", `O [ ("type", `String "integer") ]);
76
+
("has_tests", `O [ ("type", `String "boolean") ]);
77
+
] );
78
+
])
79
+
72
80
let format = Structured_output.of_json_schema schema
73
81
74
-
let analysis_config = Options.default
82
+
let analysis_config =
83
+
Options.default
75
84
|> Options.with_output_format format
76
-
|> Options.with_allowed_tools ["Read"; "Glob"; "Grep"]
85
+
|> Options.with_allowed_tools [ "Read"; "Glob"; "Grep" ]
77
86
]}
78
87
79
88
{2 Advanced Options}
···
90
99
- [User] - ~/.claude/config
91
100
- [Project] - .claude/ in project root
92
101
- [Local] - Current directory settings
93
-
- [Some \[\]] (via {!with_no_settings}) - No settings, fully isolated
102
+
- [Some []] (via {!with_no_settings}) - No settings, fully isolated
94
103
95
104
This is critical for reproducible builds in CI/CD environments.
96
105
97
106
{3 Model Fallback}
98
107
99
-
Use {!with_fallback_model} to specify an alternative model when the
100
-
primary model is unavailable or overloaded. This improves reliability. *)
108
+
Use {!with_fallback_model} to specify an alternative model when the primary
109
+
model is unavailable or overloaded. This improves reliability. *)
101
110
102
-
(** The log source for options operations *)
103
111
val src : Logs.Src.t
112
+
(** The log source for options operations *)
104
113
105
114
(** {1 Types} *)
106
115
107
-
type setting_source = User | Project | Local
108
-
(** Setting source determines which configuration files to load.
109
-
- [User]: Load user-level settings from ~/.claude/config
110
-
- [Project]: Load project-level settings from .claude/ in project root
111
-
- [Local]: Load local settings from current directory *)
116
+
type setting_source =
117
+
| User
118
+
| Project
119
+
| Local
120
+
(** Setting source determines which configuration files to load.
121
+
- [User]: Load user-level settings from ~/.claude/config
122
+
- [Project]: Load project-level settings from .claude/ in project root
123
+
- [Local]: Load local settings from current directory *)
112
124
113
125
type t
114
126
(** The type of configuration options. *)
···
147
159
?user:string ->
148
160
?output_format:Structured_output.t ->
149
161
?unknown:Jsont.json ->
150
-
unit -> t
162
+
unit ->
163
+
t
151
164
(** [create ?allowed_tools ?disallowed_tools ?max_thinking_tokens ?system_prompt
152
-
?append_system_prompt ?permission_mode ?permission_callback ?model ?cwd ?env
153
-
?continue_conversation ?resume ?max_turns ?permission_prompt_tool_name ?settings
154
-
?add_dirs ?extra_args ?debug_stderr ?hooks ?max_budget_usd ?fallback_model
155
-
?setting_sources ?max_buffer_size ?user ()]
156
-
creates a new configuration.
165
+
?append_system_prompt ?permission_mode ?permission_callback ?model ?cwd
166
+
?env ?continue_conversation ?resume ?max_turns ?permission_prompt_tool_name
167
+
?settings ?add_dirs ?extra_args ?debug_stderr ?hooks ?max_budget_usd
168
+
?fallback_model ?setting_sources ?max_buffer_size ?user ()] creates a new
169
+
configuration.
157
170
@param allowed_tools List of explicitly allowed tool names
158
171
@param disallowed_tools List of explicitly disallowed tool names
159
-
@param max_thinking_tokens Maximum tokens for thinking blocks (default: 8000)
172
+
@param max_thinking_tokens
173
+
Maximum tokens for thinking blocks (default: 8000)
160
174
@param system_prompt Replace the default system prompt
161
175
@param append_system_prompt Append to the default system prompt
162
176
@param permission_mode Permission mode to use
···
213
227
(** [env t] returns the environment variables. *)
214
228
215
229
val continue_conversation : t -> bool
216
-
(** [continue_conversation t] returns whether to continue an existing conversation. *)
230
+
(** [continue_conversation t] returns whether to continue an existing
231
+
conversation. *)
217
232
218
233
val resume : t -> string option
219
234
(** [resume t] returns the optional session ID to resume. *)
···
222
237
(** [max_turns t] returns the optional maximum number of turns. *)
223
238
224
239
val permission_prompt_tool_name : t -> string option
225
-
(** [permission_prompt_tool_name t] returns the optional tool name for permission prompts. *)
240
+
(** [permission_prompt_tool_name t] returns the optional tool name for
241
+
permission prompts. *)
226
242
227
243
val settings : t -> string option
228
244
(** [settings t] returns the optional path to settings file. *)
···
258
274
(** [output_format t] returns the optional structured output format. *)
259
275
260
276
val unknown : t -> Jsont.json
261
-
(** [unknown t] returns any unknown JSON fields that were preserved during decoding. *)
277
+
(** [unknown t] returns any unknown JSON fields that were preserved during
278
+
decoding. *)
262
279
263
280
(** {1 Builders} *)
264
281
···
287
304
(** [with_model model t] sets the model override using a typed Model.t. *)
288
305
289
306
val with_model_string : string -> t -> t
290
-
(** [with_model_string model t] sets the model override from a string.
291
-
The string is parsed using {!Model.of_string}. *)
307
+
(** [with_model_string model t] sets the model override from a string. The
308
+
string is parsed using {!Model.of_string}. *)
292
309
293
310
val with_cwd : Eio.Fs.dir_ty Eio.Path.t -> t -> t
294
311
(** [with_cwd cwd t] sets the working directory. *)
···
297
314
(** [with_env env t] sets the environment variables. *)
298
315
299
316
val with_continue_conversation : bool -> t -> t
300
-
(** [with_continue_conversation continue t] sets whether to continue conversation. *)
317
+
(** [with_continue_conversation continue t] sets whether to continue
318
+
conversation. *)
301
319
302
320
val with_resume : string -> t -> t
303
321
(** [with_resume session_id t] sets the session ID to resume. *)
···
306
324
(** [with_max_turns turns t] sets the maximum number of turns. *)
307
325
308
326
val with_permission_prompt_tool_name : string -> t -> t
309
-
(** [with_permission_prompt_tool_name tool t] sets the permission prompt tool name. *)
327
+
(** [with_permission_prompt_tool_name tool t] sets the permission prompt tool
328
+
name. *)
310
329
311
330
val with_settings : string -> t -> t
312
331
(** [with_settings path t] sets the path to settings file. *)
···
324
343
(** [with_hooks hooks t] sets the hooks configuration. *)
325
344
326
345
val with_max_budget_usd : float -> t -> t
327
-
(** [with_max_budget_usd budget t] sets the maximum spending limit in USD.
328
-
The session will terminate if this limit is exceeded. *)
346
+
(** [with_max_budget_usd budget t] sets the maximum spending limit in USD. The
347
+
session will terminate if this limit is exceeded. *)
329
348
330
349
val with_fallback_model : Model.t -> t -> t
331
-
(** [with_fallback_model model t] sets the fallback model using a typed Model.t. *)
350
+
(** [with_fallback_model model t] sets the fallback model using a typed Model.t.
351
+
*)
332
352
333
353
val with_fallback_model_string : string -> t -> t
334
354
(** [with_fallback_model_string model t] sets the fallback model from a string.
···
340
360
341
361
val with_no_settings : t -> t
342
362
(** [with_no_settings t] disables all settings loading (user, project, local).
343
-
Useful for CI/CD environments where you want isolated, reproducible behavior. *)
363
+
Useful for CI/CD environments where you want isolated, reproducible
364
+
behavior. *)
344
365
345
366
val with_max_buffer_size : int -> t -> t
346
-
(** [with_max_buffer_size size t] sets the maximum stdout buffer size in bytes. *)
367
+
(** [with_max_buffer_size size t] sets the maximum stdout buffer size in bytes.
368
+
*)
347
369
348
370
val with_user : string -> t -> t
349
371
(** [with_user user t] sets the Unix user for subprocess execution. *)
···
354
376
(** {1 Serialization} *)
355
377
356
378
val jsont : t Jsont.t
357
-
(** [jsont] is the Jsont codec for Options.t
358
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
379
+
(** [jsont] is the Jsont codec for Options.t Use [Jsont.pp_value jsont ()] for
380
+
pretty-printing. *)
359
381
360
382
(** {1 Logging} *)
361
383
+89
-87
lib/permissions.ml
+89
-87
lib/permissions.ml
···
1
1
let src = Logs.Src.create "claude.permission" ~doc:"Claude permission system"
2
+
2
3
module Log = (val Logs.src_log src : Logs.LOG)
3
4
4
5
(** Permission modes *)
5
6
module Mode = struct
6
-
type t =
7
-
| Default
8
-
| Accept_edits
9
-
| Plan
10
-
| Bypass_permissions
7
+
type t = Default | Accept_edits | Plan | Bypass_permissions
11
8
12
9
let to_string = function
13
10
| Default -> "default"
···
20
17
| "acceptEdits" -> Accept_edits
21
18
| "plan" -> Plan
22
19
| "bypassPermissions" -> Bypass_permissions
23
-
| s -> raise (Invalid_argument (Printf.sprintf "Mode.of_string: unknown mode %s" s))
20
+
| s ->
21
+
raise
22
+
(Invalid_argument (Printf.sprintf "Mode.of_string: unknown mode %s" s))
24
23
25
24
let jsont : t Jsont.t =
26
-
Jsont.enum [
27
-
"default", Default;
28
-
"acceptEdits", Accept_edits;
29
-
"plan", Plan;
30
-
"bypassPermissions", Bypass_permissions;
31
-
]
25
+
Jsont.enum
26
+
[
27
+
("default", Default);
28
+
("acceptEdits", Accept_edits);
29
+
("plan", Plan);
30
+
("bypassPermissions", Bypass_permissions);
31
+
]
32
32
end
33
33
34
34
(** Permission behaviors *)
35
35
module Behavior = struct
36
36
type t = Allow | Deny | Ask
37
37
38
-
let to_string = function
39
-
| Allow -> "allow"
40
-
| Deny -> "deny"
41
-
| Ask -> "ask"
38
+
let to_string = function Allow -> "allow" | Deny -> "deny" | Ask -> "ask"
42
39
43
40
let of_string = function
44
41
| "allow" -> Allow
45
42
| "deny" -> Deny
46
43
| "ask" -> Ask
47
-
| s -> raise (Invalid_argument (Printf.sprintf "Behavior.of_string: unknown behavior %s" s))
44
+
| s ->
45
+
raise
46
+
(Invalid_argument
47
+
(Printf.sprintf "Behavior.of_string: unknown behavior %s" s))
48
48
49
49
let jsont : t Jsont.t =
50
-
Jsont.enum [
51
-
"allow", Allow;
52
-
"deny", Deny;
53
-
"ask", Ask;
54
-
]
50
+
Jsont.enum [ ("allow", Allow); ("deny", Deny); ("ask", Ask) ]
55
51
end
56
52
57
53
(** Permission rules *)
···
64
60
65
61
let create ~tool_name ?rule_content ?(unknown = Unknown.empty) () =
66
62
{ tool_name; rule_content; unknown }
63
+
67
64
let tool_name t = t.tool_name
68
65
let rule_content t = t.rule_content
69
66
let unknown t = t.unknown
70
67
71
68
let jsont : t Jsont.t =
72
-
let make tool_name rule_content unknown = { tool_name; rule_content; unknown } in
69
+
let make tool_name rule_content unknown =
70
+
{ tool_name; rule_content; unknown }
71
+
in
73
72
Jsont.Object.map ~kind:"Rule" make
74
73
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:tool_name
75
74
|> Jsont.Object.opt_mem "rule_content" Jsont.string ~enc:rule_content
···
90
89
| "projectSettings" -> Project_settings
91
90
| "localSettings" -> Local_settings
92
91
| "session" -> Session
93
-
| s -> raise (Invalid_argument (Printf.sprintf "destination_of_string: unknown %s" s))
92
+
| s ->
93
+
raise
94
+
(Invalid_argument
95
+
(Printf.sprintf "destination_of_string: unknown %s" s))
94
96
95
97
let destination_jsont : destination Jsont.t =
96
-
Jsont.enum [
97
-
"userSettings", User_settings;
98
-
"projectSettings", Project_settings;
99
-
"localSettings", Local_settings;
100
-
"session", Session;
101
-
]
98
+
Jsont.enum
99
+
[
100
+
("userSettings", User_settings);
101
+
("projectSettings", Project_settings);
102
+
("localSettings", Local_settings);
103
+
("session", Session);
104
+
]
102
105
103
106
type update_type =
104
107
| Add_rules
···
115
118
| "setMode" -> Set_mode
116
119
| "addDirectories" -> Add_directories
117
120
| "removeDirectories" -> Remove_directories
118
-
| s -> raise (Invalid_argument (Printf.sprintf "update_type_of_string: unknown %s" s))
121
+
| s ->
122
+
raise
123
+
(Invalid_argument
124
+
(Printf.sprintf "update_type_of_string: unknown %s" s))
119
125
120
126
let update_type_jsont : update_type Jsont.t =
121
-
Jsont.enum [
122
-
"addRules", Add_rules;
123
-
"replaceRules", Replace_rules;
124
-
"removeRules", Remove_rules;
125
-
"setMode", Set_mode;
126
-
"addDirectories", Add_directories;
127
-
"removeDirectories", Remove_directories;
128
-
]
127
+
Jsont.enum
128
+
[
129
+
("addRules", Add_rules);
130
+
("replaceRules", Replace_rules);
131
+
("removeRules", Remove_rules);
132
+
("setMode", Set_mode);
133
+
("addDirectories", Add_directories);
134
+
("removeDirectories", Remove_directories);
135
+
]
129
136
130
137
type t = {
131
138
update_type : update_type;
···
137
144
unknown : Unknown.t;
138
145
}
139
146
140
-
let create ~update_type ?rules ?behavior ?mode ?directories ?destination ?(unknown = Unknown.empty) () =
147
+
let create ~update_type ?rules ?behavior ?mode ?directories ?destination
148
+
?(unknown = Unknown.empty) () =
141
149
{ update_type; rules; behavior; mode; directories; destination; unknown }
142
150
143
151
let update_type t = t.update_type
···
157
165
|> Jsont.Object.opt_mem "rules" (Jsont.list Rule.jsont) ~enc:rules
158
166
|> Jsont.Object.opt_mem "behavior" Behavior.jsont ~enc:behavior
159
167
|> Jsont.Object.opt_mem "mode" Mode.jsont ~enc:mode
160
-
|> Jsont.Object.opt_mem "directories" (Jsont.list Jsont.string) ~enc:directories
168
+
|> Jsont.Object.opt_mem "directories" (Jsont.list Jsont.string)
169
+
~enc:directories
161
170
|> Jsont.Object.opt_mem "destination" destination_jsont ~enc:destination
162
171
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
163
172
|> Jsont.Object.finish
···
165
174
166
175
(** Permission context for callbacks *)
167
176
module Context = struct
168
-
type t = {
169
-
suggestions : Update.t list;
170
-
unknown : Unknown.t;
171
-
}
177
+
type t = { suggestions : Update.t list; unknown : Unknown.t }
172
178
173
-
let create ?(suggestions = []) ?(unknown = Unknown.empty) () = { suggestions; unknown }
179
+
let create ?(suggestions = []) ?(unknown = Unknown.empty) () =
180
+
{ suggestions; unknown }
181
+
174
182
let suggestions t = t.suggestions
175
183
let unknown t = t.unknown
176
184
177
185
let jsont : t Jsont.t =
178
186
let make suggestions unknown = { suggestions; unknown } in
179
187
Jsont.Object.map ~kind:"Context" make
180
-
|> Jsont.Object.mem "suggestions" (Jsont.list Update.jsont) ~enc:suggestions ~dec_absent:[]
188
+
|> Jsont.Object.mem "suggestions" (Jsont.list Update.jsont) ~enc:suggestions
189
+
~dec_absent:[]
181
190
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
182
191
|> Jsont.Object.finish
183
192
end
···
190
199
updated_permissions : Update.t list option;
191
200
unknown : Unknown.t;
192
201
}
193
-
| Deny of {
194
-
message : string;
195
-
interrupt : bool;
196
-
unknown : Unknown.t;
197
-
}
202
+
| Deny of { message : string; interrupt : bool; unknown : Unknown.t }
198
203
199
204
let allow ?updated_input ?updated_permissions ?(unknown = Unknown.empty) () =
200
205
Allow { updated_input; updated_permissions; unknown }
···
209
214
in
210
215
Jsont.Object.map ~kind:"AllowRecord" make
211
216
|> Jsont.Object.opt_mem "updated_input" Jsont.json ~enc:(function
212
-
| Allow { updated_input; _ } -> updated_input
213
-
| _ -> None)
214
-
|> Jsont.Object.opt_mem "updated_permissions" (Jsont.list Update.jsont) ~enc:(function
217
+
| Allow { updated_input; _ } -> updated_input
218
+
| _ -> None)
219
+
|> Jsont.Object.opt_mem "updated_permissions" (Jsont.list Update.jsont)
220
+
~enc:(function
215
221
| Allow { updated_permissions; _ } -> updated_permissions
216
222
| _ -> None)
217
223
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(function
218
-
| Allow { unknown; _ } -> unknown
219
-
| _ -> Unknown.empty)
224
+
| Allow { unknown; _ } -> unknown
225
+
| _ -> Unknown.empty)
220
226
|> Jsont.Object.finish
221
227
in
222
228
let deny_record =
···
225
231
in
226
232
Jsont.Object.map ~kind:"DenyRecord" make
227
233
|> Jsont.Object.mem "message" Jsont.string ~enc:(function
228
-
| Deny { message; _ } -> message
229
-
| _ -> "")
234
+
| Deny { message; _ } -> message
235
+
| _ -> "")
230
236
|> Jsont.Object.mem "interrupt" Jsont.bool ~enc:(function
231
-
| Deny { interrupt; _ } -> interrupt
232
-
| _ -> false)
237
+
| Deny { interrupt; _ } -> interrupt
238
+
| _ -> false)
233
239
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(function
234
-
| Deny { unknown; _ } -> unknown
235
-
| _ -> Unknown.empty)
240
+
| Deny { unknown; _ } -> unknown
241
+
| _ -> Unknown.empty)
236
242
|> Jsont.Object.finish
237
243
in
238
-
let case_allow = Jsont.Object.Case.map "allow" allow_record ~dec:(fun v -> v) in
239
-
let case_deny = Jsont.Object.Case.map "deny" deny_record ~dec:(fun v -> v) in
244
+
let case_allow =
245
+
Jsont.Object.Case.map "allow" allow_record ~dec:(fun v -> v)
246
+
in
247
+
let case_deny =
248
+
Jsont.Object.Case.map "deny" deny_record ~dec:(fun v -> v)
249
+
in
240
250
241
251
let enc_case = function
242
252
| Allow _ as v -> Jsont.Object.Case.value case_allow v
243
253
| Deny _ as v -> Jsont.Object.Case.value case_deny v
244
254
in
245
255
246
-
let cases = Jsont.Object.Case.[
247
-
make case_allow;
248
-
make case_deny
249
-
] in
256
+
let cases = Jsont.Object.Case.[ make case_allow; make case_deny ] in
250
257
251
258
Jsont.Object.map ~kind:"Result" Fun.id
252
259
|> Jsont.Object.case_mem "behavior" Jsont.string ~enc:Fun.id ~enc_case cases
253
-
~tag_to_string:Fun.id ~tag_compare:String.compare
260
+
~tag_to_string:Fun.id ~tag_compare:String.compare
254
261
|> Jsont.Object.finish
255
262
end
256
263
264
+
type callback =
265
+
tool_name:string -> input:Jsont.json -> context:Context.t -> Result.t
257
266
(** Permission callback type *)
258
-
type callback =
259
-
tool_name:string ->
260
-
input:Jsont.json ->
261
-
context:Context.t ->
262
-
Result.t
263
267
264
268
(** Default callbacks *)
265
-
let default_allow_callback ~tool_name:_ ~input:_ ~context:_ =
266
-
Result.allow ()
269
+
let default_allow_callback ~tool_name:_ ~input:_ ~context:_ = Result.allow ()
267
270
268
271
let discovery_callback log ~tool_name:_ ~input:_ ~context =
269
-
List.iter (fun update ->
270
-
match Update.rules update with
271
-
| Some rules ->
272
-
List.iter (fun rule ->
273
-
log := rule :: !log
274
-
) rules
275
-
| None -> ()
276
-
) (Context.suggestions context);
272
+
List.iter
273
+
(fun update ->
274
+
match Update.rules update with
275
+
| Some rules -> List.iter (fun rule -> log := rule :: !log) rules
276
+
| None -> ())
277
+
(Context.suggestions context);
277
278
Result.allow ()
278
279
279
280
(** Logging *)
280
281
let log_permission_check ~tool_name ~result =
281
282
match result with
282
-
| Result.Allow _ ->
283
+
| Result.Allow _ ->
283
284
Log.info (fun m -> m "Permission granted for tool: %s" tool_name)
284
285
| Result.Deny { message; _ } ->
285
-
Log.warn (fun m -> m "Permission denied for tool %s: %s" tool_name message)
286
+
Log.warn (fun m ->
287
+
m "Permission denied for tool %s: %s" tool_name message)
+44
-39
lib/permissions.mli
+44
-39
lib/permissions.mli
···
1
1
(** Permission system for Claude tool invocations.
2
2
3
-
This module provides a permission system for controlling
4
-
which tools Claude can invoke and how they can be used. It includes
5
-
support for permission modes, rules, updates, and callbacks. *)
3
+
This module provides a permission system for controlling which tools Claude
4
+
can invoke and how they can be used. It includes support for permission
5
+
modes, rules, updates, and callbacks. *)
6
6
7
-
(** The log source for permission operations *)
8
7
val src : Logs.Src.t
8
+
(** The log source for permission operations *)
9
9
10
10
(** {1 Permission Modes} *)
11
11
12
12
module Mode : sig
13
13
(** Permission modes control the overall behavior of the permission system. *)
14
14
15
+
(** The type of permission modes. *)
15
16
type t =
16
17
| Default (** Standard permission mode with normal checks *)
17
18
| Accept_edits (** Automatically accept file edits *)
18
19
| Plan (** Planning mode with restricted execution *)
19
20
| Bypass_permissions (** Bypass all permission checks *)
20
-
(** The type of permission modes. *)
21
21
22
22
val to_string : t -> string
23
23
(** [to_string t] converts a mode to its string representation. *)
···
27
27
@raise Invalid_argument if the string is not a valid mode. *)
28
28
29
29
val jsont : t Jsont.t
30
-
(** [jsont] is the Jsont codec for permission modes.
31
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
30
+
(** [jsont] is the Jsont codec for permission modes. Use
31
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
32
32
end
33
33
34
34
(** {1 Permission Behaviors} *)
···
36
36
module Behavior : sig
37
37
(** Behaviors determine how permission requests are handled. *)
38
38
39
+
(** The type of permission behaviors. *)
39
40
type t =
40
41
| Allow (** Allow the operation *)
41
42
| Deny (** Deny the operation *)
42
43
| Ask (** Ask the user for permission *)
43
-
(** The type of permission behaviors. *)
44
44
45
45
val to_string : t -> string
46
46
(** [to_string t] converts a behavior to its string representation. *)
···
50
50
@raise Invalid_argument if the string is not a valid behavior. *)
51
51
52
52
val jsont : t Jsont.t
53
-
(** [jsont] is the Jsont codec for permission behaviors.
54
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
53
+
(** [jsont] is the Jsont codec for permission behaviors. Use
54
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
55
55
end
56
56
57
57
(** {1 Permission Rules} *)
···
66
66
}
67
67
(** The type of permission rules. *)
68
68
69
-
val create : tool_name:string -> ?rule_content:string -> ?unknown:Unknown.t -> unit -> t
69
+
val create :
70
+
tool_name:string -> ?rule_content:string -> ?unknown:Unknown.t -> unit -> t
70
71
(** [create ~tool_name ?rule_content ?unknown ()] creates a new rule.
71
72
@param tool_name The name of the tool this rule applies to
72
73
@param rule_content Optional rule specification or pattern
···
82
83
(** [unknown t] returns the unknown fields. *)
83
84
84
85
val jsont : t Jsont.t
85
-
(** [jsont] is the Jsont codec for permission rules.
86
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
86
+
(** [jsont] is the Jsont codec for permission rules. Use
87
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
87
88
end
88
89
89
90
(** {1 Permission Updates} *)
···
91
92
module Update : sig
92
93
(** Updates modify permission settings. *)
93
94
95
+
(** The destination for permission updates. *)
94
96
type destination =
95
97
| User_settings (** Apply to user settings *)
96
98
| Project_settings (** Apply to project settings *)
97
99
| Local_settings (** Apply to local settings *)
98
100
| Session (** Apply to current session only *)
99
-
(** The destination for permission updates. *)
100
101
102
+
(** The type of permission update. *)
101
103
type update_type =
102
104
| Add_rules (** Add new rules *)
103
105
| Replace_rules (** Replace existing rules *)
···
105
107
| Set_mode (** Set permission mode *)
106
108
| Add_directories (** Add allowed directories *)
107
109
| Remove_directories (** Remove allowed directories *)
108
-
(** The type of permission update. *)
109
110
110
111
type t
111
112
(** The type of permission updates. *)
···
118
119
?directories:string list ->
119
120
?destination:destination ->
120
121
?unknown:Unknown.t ->
121
-
unit -> t
122
-
(** [create ~update_type ?rules ?behavior ?mode ?directories ?destination ?unknown ()]
123
-
creates a new permission update.
122
+
unit ->
123
+
t
124
+
(** [create ~update_type ?rules ?behavior ?mode ?directories ?destination
125
+
?unknown ()] creates a new permission update.
124
126
@param update_type The type of update to perform
125
127
@param rules Optional list of rules to add/remove/replace
126
128
@param behavior Optional behavior to set
···
151
153
(** [unknown t] returns the unknown fields. *)
152
154
153
155
val jsont : t Jsont.t
154
-
(** [jsont] is the Jsont codec for permission updates.
155
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
156
+
(** [jsont] is the Jsont codec for permission updates. Use
157
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
156
158
end
157
159
158
160
(** {1 Permission Context} *)
···
178
180
(** [unknown t] returns the unknown fields. *)
179
181
180
182
val jsont : t Jsont.t
181
-
(** [jsont] is the Jsont codec for permission context.
182
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
183
+
(** [jsont] is the Jsont codec for permission context. Use
184
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
183
185
end
184
186
185
187
(** {1 Permission Results} *)
···
190
192
type t =
191
193
| Allow of {
192
194
updated_input : Jsont.json option; (** Modified tool input *)
193
-
updated_permissions : Update.t list option; (** Permission updates to apply *)
195
+
updated_permissions : Update.t list option;
196
+
(** Permission updates to apply *)
194
197
unknown : Unknown.t; (** Unknown fields *)
195
198
}
196
199
| Deny of {
197
200
message : string; (** Reason for denial *)
198
201
interrupt : bool; (** Whether to interrupt execution *)
199
202
unknown : Unknown.t; (** Unknown fields *)
200
-
}
201
-
(** The type of permission results. *)
203
+
} (** The type of permission results. *)
202
204
203
-
val allow : ?updated_input:Jsont.json -> ?updated_permissions:Update.t list -> ?unknown:Unknown.t -> unit -> t
204
-
(** [allow ?updated_input ?updated_permissions ?unknown ()] creates an allow result.
205
+
val allow :
206
+
?updated_input:Jsont.json ->
207
+
?updated_permissions:Update.t list ->
208
+
?unknown:Unknown.t ->
209
+
unit ->
210
+
t
211
+
(** [allow ?updated_input ?updated_permissions ?unknown ()] creates an allow
212
+
result.
205
213
@param updated_input Optional modified tool input
206
214
@param updated_permissions Optional permission updates to apply
207
215
@param unknown Optional unknown fields to preserve *)
···
213
221
@param unknown Optional unknown fields to preserve *)
214
222
215
223
val jsont : t Jsont.t
216
-
(** [jsont] is the Jsont codec for permission results.
217
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
224
+
(** [jsont] is the Jsont codec for permission results. Use
225
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
218
226
end
219
227
220
228
(** {1 Permission Callbacks} *)
221
229
222
230
type callback =
223
-
tool_name:string ->
224
-
input:Jsont.json ->
225
-
context:Context.t ->
226
-
Result.t
227
-
(** The type of permission callbacks. Callbacks are invoked when Claude
228
-
attempts to use a tool, allowing custom permission logic. *)
231
+
tool_name:string -> input:Jsont.json -> context:Context.t -> Result.t
232
+
(** The type of permission callbacks. Callbacks are invoked when Claude attempts
233
+
to use a tool, allowing custom permission logic. *)
229
234
230
235
val default_allow_callback : callback
231
236
(** [default_allow_callback] always allows tool invocations. *)
232
237
233
238
val discovery_callback : Rule.t list ref -> callback
234
-
(** [discovery_callback log] creates a callback that collects suggested
235
-
rules into the provided reference. Useful for discovering what
236
-
permissions an operation requires. *)
239
+
(** [discovery_callback log] creates a callback that collects suggested rules
240
+
into the provided reference. Useful for discovering what permissions an
241
+
operation requires. *)
237
242
238
243
(** {1 Logging} *)
239
244
240
245
val log_permission_check : tool_name:string -> result:Result.t -> unit
241
-
(** [log_permission_check ~tool_name ~result] logs a permission check result. *)
246
+
(** [log_permission_check ~tool_name ~result] logs a permission check result. *)
+216
-157
lib/sdk_control.ml
+216
-157
lib/sdk_control.ml
···
1
-
let src = Logs.Src.create "claude.sdk_control" ~doc:"Claude SDK control protocol"
1
+
let src =
2
+
Logs.Src.create "claude.sdk_control" ~doc:"Claude SDK control protocol"
3
+
2
4
module Log = (val Logs.src_log src : Logs.LOG)
3
5
4
6
module Request = struct
5
-
type interrupt = {
6
-
subtype : [`Interrupt];
7
-
unknown : Unknown.t;
8
-
}
7
+
type interrupt = { subtype : [ `Interrupt ]; unknown : Unknown.t }
9
8
10
9
type permission = {
11
-
subtype : [`Can_use_tool];
10
+
subtype : [ `Can_use_tool ];
12
11
tool_name : string;
13
12
input : Jsont.json;
14
13
permission_suggestions : Permissions.Update.t list option;
···
17
16
}
18
17
19
18
type initialize = {
20
-
subtype : [`Initialize];
19
+
subtype : [ `Initialize ];
21
20
hooks : (string * Jsont.json) list option;
22
21
unknown : Unknown.t;
23
22
}
24
23
25
24
type set_permission_mode = {
26
-
subtype : [`Set_permission_mode];
25
+
subtype : [ `Set_permission_mode ];
27
26
mode : Permissions.Mode.t;
28
27
unknown : Unknown.t;
29
28
}
30
29
31
30
type hook_callback = {
32
-
subtype : [`Hook_callback];
31
+
subtype : [ `Hook_callback ];
33
32
callback_id : string;
34
33
input : Jsont.json;
35
34
tool_use_id : string option;
···
37
36
}
38
37
39
38
type mcp_message = {
40
-
subtype : [`Mcp_message];
39
+
subtype : [ `Mcp_message ];
41
40
server_name : string;
42
41
message : Jsont.json;
43
42
unknown : Unknown.t;
44
43
}
45
44
46
45
type set_model = {
47
-
subtype : [`Set_model];
46
+
subtype : [ `Set_model ];
48
47
model : string;
49
48
unknown : Unknown.t;
50
49
}
51
50
52
-
type get_server_info = {
53
-
subtype : [`Get_server_info];
54
-
unknown : Unknown.t;
55
-
}
51
+
type get_server_info = { subtype : [ `Get_server_info ]; unknown : Unknown.t }
56
52
57
53
type t =
58
54
| Interrupt of interrupt
···
63
59
| Mcp_message of mcp_message
64
60
| Set_model of set_model
65
61
| Get_server_info of get_server_info
66
-
62
+
67
63
let interrupt ?(unknown = Unknown.empty) () =
68
64
Interrupt { subtype = `Interrupt; unknown }
69
65
70
-
let permission ~tool_name ~input ?permission_suggestions ?blocked_path ?(unknown = Unknown.empty) () =
71
-
Permission {
72
-
subtype = `Can_use_tool;
73
-
tool_name;
74
-
input;
75
-
permission_suggestions;
76
-
blocked_path;
77
-
unknown;
78
-
}
66
+
let permission ~tool_name ~input ?permission_suggestions ?blocked_path
67
+
?(unknown = Unknown.empty) () =
68
+
Permission
69
+
{
70
+
subtype = `Can_use_tool;
71
+
tool_name;
72
+
input;
73
+
permission_suggestions;
74
+
blocked_path;
75
+
unknown;
76
+
}
79
77
80
78
let initialize ?hooks ?(unknown = Unknown.empty) () =
81
79
Initialize { subtype = `Initialize; hooks; unknown }
···
83
81
let set_permission_mode ~mode ?(unknown = Unknown.empty) () =
84
82
Set_permission_mode { subtype = `Set_permission_mode; mode; unknown }
85
83
86
-
let hook_callback ~callback_id ~input ?tool_use_id ?(unknown = Unknown.empty) () =
87
-
Hook_callback {
88
-
subtype = `Hook_callback;
89
-
callback_id;
90
-
input;
91
-
tool_use_id;
92
-
unknown;
93
-
}
84
+
let hook_callback ~callback_id ~input ?tool_use_id ?(unknown = Unknown.empty)
85
+
() =
86
+
Hook_callback
87
+
{ subtype = `Hook_callback; callback_id; input; tool_use_id; unknown }
94
88
95
89
let mcp_message ~server_name ~message ?(unknown = Unknown.empty) () =
96
-
Mcp_message {
97
-
subtype = `Mcp_message;
98
-
server_name;
99
-
message;
100
-
unknown;
101
-
}
90
+
Mcp_message { subtype = `Mcp_message; server_name; message; unknown }
102
91
103
92
let set_model ~model ?(unknown = Unknown.empty) () =
104
93
Set_model { subtype = `Set_model; model; unknown }
···
108
97
109
98
(* Individual record codecs *)
110
99
let interrupt_jsont : interrupt Jsont.t =
111
-
let make (unknown : Unknown.t) : interrupt = { subtype = `Interrupt; unknown } in
100
+
let make (unknown : Unknown.t) : interrupt =
101
+
{ subtype = `Interrupt; unknown }
102
+
in
112
103
Jsont.Object.map ~kind:"Interrupt" make
113
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : interrupt) -> r.unknown)
104
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : interrupt) ->
105
+
r.unknown)
114
106
|> Jsont.Object.finish
115
107
116
108
let permission_jsont : permission Jsont.t =
117
-
let make tool_name input permission_suggestions blocked_path (unknown : Unknown.t) : permission =
118
-
{ subtype = `Can_use_tool; tool_name; input; permission_suggestions; blocked_path; unknown }
109
+
let make tool_name input permission_suggestions blocked_path
110
+
(unknown : Unknown.t) : permission =
111
+
{
112
+
subtype = `Can_use_tool;
113
+
tool_name;
114
+
input;
115
+
permission_suggestions;
116
+
blocked_path;
117
+
unknown;
118
+
}
119
119
in
120
120
Jsont.Object.map ~kind:"Permission" make
121
-
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:(fun (r : permission) -> r.tool_name)
122
-
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : permission) -> r.input)
123
-
|> Jsont.Object.opt_mem "permission_suggestions" (Jsont.list Permissions.Update.jsont) ~enc:(fun (r : permission) -> r.permission_suggestions)
124
-
|> Jsont.Object.opt_mem "blocked_path" Jsont.string ~enc:(fun (r : permission) -> r.blocked_path)
125
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : permission) -> r.unknown)
121
+
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:(fun (r : permission) ->
122
+
r.tool_name)
123
+
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : permission) ->
124
+
r.input)
125
+
|> Jsont.Object.opt_mem "permission_suggestions"
126
+
(Jsont.list Permissions.Update.jsont) ~enc:(fun (r : permission) ->
127
+
r.permission_suggestions)
128
+
|> Jsont.Object.opt_mem "blocked_path" Jsont.string
129
+
~enc:(fun (r : permission) -> r.blocked_path)
130
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : permission) ->
131
+
r.unknown)
126
132
|> Jsont.Object.finish
127
133
128
134
let initialize_jsont : initialize Jsont.t =
129
135
(* The hooks field is an object with string keys and json values *)
130
136
let hooks_map_jsont = Jsont.Object.as_string_map Jsont.json in
131
-
let module StringMap = Map.Make(String) in
132
-
let hooks_jsont = Jsont.map
133
-
~dec:(fun m -> StringMap.bindings m)
134
-
~enc:(fun l -> StringMap.of_seq (List.to_seq l))
135
-
hooks_map_jsont
137
+
let module StringMap = Map.Make (String) in
138
+
let hooks_jsont =
139
+
Jsont.map
140
+
~dec:(fun m -> StringMap.bindings m)
141
+
~enc:(fun l -> StringMap.of_seq (List.to_seq l))
142
+
hooks_map_jsont
136
143
in
137
-
let make hooks (unknown : Unknown.t) : initialize = { subtype = `Initialize; hooks; unknown } in
144
+
let make hooks (unknown : Unknown.t) : initialize =
145
+
{ subtype = `Initialize; hooks; unknown }
146
+
in
138
147
Jsont.Object.map ~kind:"Initialize" make
139
-
|> Jsont.Object.opt_mem "hooks" hooks_jsont ~enc:(fun (r : initialize) -> r.hooks)
140
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : initialize) -> r.unknown)
148
+
|> Jsont.Object.opt_mem "hooks" hooks_jsont ~enc:(fun (r : initialize) ->
149
+
r.hooks)
150
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : initialize) ->
151
+
r.unknown)
141
152
|> Jsont.Object.finish
142
153
143
154
let set_permission_mode_jsont : set_permission_mode Jsont.t =
144
-
let make mode (unknown : Unknown.t) : set_permission_mode = { subtype = `Set_permission_mode; mode; unknown } in
155
+
let make mode (unknown : Unknown.t) : set_permission_mode =
156
+
{ subtype = `Set_permission_mode; mode; unknown }
157
+
in
145
158
Jsont.Object.map ~kind:"SetPermissionMode" make
146
-
|> Jsont.Object.mem "mode" Permissions.Mode.jsont ~enc:(fun (r : set_permission_mode) -> r.mode)
147
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : set_permission_mode) -> r.unknown)
159
+
|> Jsont.Object.mem "mode" Permissions.Mode.jsont
160
+
~enc:(fun (r : set_permission_mode) -> r.mode)
161
+
|> Jsont.Object.keep_unknown Jsont.json_mems
162
+
~enc:(fun (r : set_permission_mode) -> r.unknown)
148
163
|> Jsont.Object.finish
149
164
150
165
let hook_callback_jsont : hook_callback Jsont.t =
151
-
let make callback_id input tool_use_id (unknown : Unknown.t) : hook_callback =
166
+
let make callback_id input tool_use_id (unknown : Unknown.t) : hook_callback
167
+
=
152
168
{ subtype = `Hook_callback; callback_id; input; tool_use_id; unknown }
153
169
in
154
170
Jsont.Object.map ~kind:"HookCallback" make
155
-
|> Jsont.Object.mem "callback_id" Jsont.string ~enc:(fun (r : hook_callback) -> r.callback_id)
156
-
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : hook_callback) -> r.input)
157
-
|> Jsont.Object.opt_mem "tool_use_id" Jsont.string ~enc:(fun (r : hook_callback) -> r.tool_use_id)
158
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : hook_callback) -> r.unknown)
171
+
|> Jsont.Object.mem "callback_id" Jsont.string
172
+
~enc:(fun (r : hook_callback) -> r.callback_id)
173
+
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : hook_callback) ->
174
+
r.input)
175
+
|> Jsont.Object.opt_mem "tool_use_id" Jsont.string
176
+
~enc:(fun (r : hook_callback) -> r.tool_use_id)
177
+
|> Jsont.Object.keep_unknown Jsont.json_mems
178
+
~enc:(fun (r : hook_callback) -> r.unknown)
159
179
|> Jsont.Object.finish
160
180
161
181
let mcp_message_jsont : mcp_message Jsont.t =
···
163
183
{ subtype = `Mcp_message; server_name; message; unknown }
164
184
in
165
185
Jsont.Object.map ~kind:"McpMessage" make
166
-
|> Jsont.Object.mem "server_name" Jsont.string ~enc:(fun (r : mcp_message) -> r.server_name)
167
-
|> Jsont.Object.mem "message" Jsont.json ~enc:(fun (r : mcp_message) -> r.message)
168
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : mcp_message) -> r.unknown)
186
+
|> Jsont.Object.mem "server_name" Jsont.string
187
+
~enc:(fun (r : mcp_message) -> r.server_name)
188
+
|> Jsont.Object.mem "message" Jsont.json ~enc:(fun (r : mcp_message) ->
189
+
r.message)
190
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : mcp_message) ->
191
+
r.unknown)
169
192
|> Jsont.Object.finish
170
193
171
194
let set_model_jsont : set_model Jsont.t =
172
-
let make model (unknown : Unknown.t) : set_model = { subtype = `Set_model; model; unknown } in
195
+
let make model (unknown : Unknown.t) : set_model =
196
+
{ subtype = `Set_model; model; unknown }
197
+
in
173
198
Jsont.Object.map ~kind:"SetModel" make
174
-
|> Jsont.Object.mem "model" Jsont.string ~enc:(fun (r : set_model) -> r.model)
175
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : set_model) -> r.unknown)
199
+
|> Jsont.Object.mem "model" Jsont.string ~enc:(fun (r : set_model) ->
200
+
r.model)
201
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : set_model) ->
202
+
r.unknown)
176
203
|> Jsont.Object.finish
177
204
178
205
let get_server_info_jsont : get_server_info Jsont.t =
179
-
let make (unknown : Unknown.t) : get_server_info = { subtype = `Get_server_info; unknown } in
206
+
let make (unknown : Unknown.t) : get_server_info =
207
+
{ subtype = `Get_server_info; unknown }
208
+
in
180
209
Jsont.Object.map ~kind:"GetServerInfo" make
181
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : get_server_info) -> r.unknown)
210
+
|> Jsont.Object.keep_unknown Jsont.json_mems
211
+
~enc:(fun (r : get_server_info) -> r.unknown)
182
212
|> Jsont.Object.finish
183
213
184
214
(* Main variant codec using subtype discriminator *)
185
215
let jsont : t Jsont.t =
186
-
let case_interrupt = Jsont.Object.Case.map "interrupt" interrupt_jsont ~dec:(fun v -> Interrupt v) in
187
-
let case_permission = Jsont.Object.Case.map "can_use_tool" permission_jsont ~dec:(fun v -> Permission v) in
188
-
let case_initialize = Jsont.Object.Case.map "initialize" initialize_jsont ~dec:(fun v -> Initialize v) in
189
-
let case_set_permission_mode = Jsont.Object.Case.map "set_permission_mode" set_permission_mode_jsont ~dec:(fun v -> Set_permission_mode v) in
190
-
let case_hook_callback = Jsont.Object.Case.map "hook_callback" hook_callback_jsont ~dec:(fun v -> Hook_callback v) in
191
-
let case_mcp_message = Jsont.Object.Case.map "mcp_message" mcp_message_jsont ~dec:(fun v -> Mcp_message v) in
192
-
let case_set_model = Jsont.Object.Case.map "set_model" set_model_jsont ~dec:(fun v -> Set_model v) in
193
-
let case_get_server_info = Jsont.Object.Case.map "get_server_info" get_server_info_jsont ~dec:(fun v -> Get_server_info v) in
216
+
let case_interrupt =
217
+
Jsont.Object.Case.map "interrupt" interrupt_jsont ~dec:(fun v ->
218
+
Interrupt v)
219
+
in
220
+
let case_permission =
221
+
Jsont.Object.Case.map "can_use_tool" permission_jsont ~dec:(fun v ->
222
+
Permission v)
223
+
in
224
+
let case_initialize =
225
+
Jsont.Object.Case.map "initialize" initialize_jsont ~dec:(fun v ->
226
+
Initialize v)
227
+
in
228
+
let case_set_permission_mode =
229
+
Jsont.Object.Case.map "set_permission_mode" set_permission_mode_jsont
230
+
~dec:(fun v -> Set_permission_mode v)
231
+
in
232
+
let case_hook_callback =
233
+
Jsont.Object.Case.map "hook_callback" hook_callback_jsont ~dec:(fun v ->
234
+
Hook_callback v)
235
+
in
236
+
let case_mcp_message =
237
+
Jsont.Object.Case.map "mcp_message" mcp_message_jsont ~dec:(fun v ->
238
+
Mcp_message v)
239
+
in
240
+
let case_set_model =
241
+
Jsont.Object.Case.map "set_model" set_model_jsont ~dec:(fun v ->
242
+
Set_model v)
243
+
in
244
+
let case_get_server_info =
245
+
Jsont.Object.Case.map "get_server_info" get_server_info_jsont
246
+
~dec:(fun v -> Get_server_info v)
247
+
in
194
248
195
249
let enc_case = function
196
250
| Interrupt v -> Jsont.Object.Case.value case_interrupt v
197
251
| Permission v -> Jsont.Object.Case.value case_permission v
198
252
| Initialize v -> Jsont.Object.Case.value case_initialize v
199
-
| Set_permission_mode v -> Jsont.Object.Case.value case_set_permission_mode v
253
+
| Set_permission_mode v ->
254
+
Jsont.Object.Case.value case_set_permission_mode v
200
255
| Hook_callback v -> Jsont.Object.Case.value case_hook_callback v
201
256
| Mcp_message v -> Jsont.Object.Case.value case_mcp_message v
202
257
| Set_model v -> Jsont.Object.Case.value case_set_model v
203
258
| Get_server_info v -> Jsont.Object.Case.value case_get_server_info v
204
259
in
205
260
206
-
let cases = Jsont.Object.Case.[
207
-
make case_interrupt;
208
-
make case_permission;
209
-
make case_initialize;
210
-
make case_set_permission_mode;
211
-
make case_hook_callback;
212
-
make case_mcp_message;
213
-
make case_set_model;
214
-
make case_get_server_info;
215
-
] in
261
+
let cases =
262
+
Jsont.Object.Case.
263
+
[
264
+
make case_interrupt;
265
+
make case_permission;
266
+
make case_initialize;
267
+
make case_set_permission_mode;
268
+
make case_hook_callback;
269
+
make case_mcp_message;
270
+
make case_set_model;
271
+
make case_get_server_info;
272
+
]
273
+
in
216
274
217
275
Jsont.Object.map ~kind:"Request" Fun.id
218
276
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
219
-
~tag_to_string:Fun.id ~tag_compare:String.compare
277
+
~tag_to_string:Fun.id ~tag_compare:String.compare
220
278
|> Jsont.Object.finish
221
279
end
222
280
223
281
module Response = struct
224
282
type success = {
225
-
subtype : [`Success];
283
+
subtype : [ `Success ];
226
284
request_id : string;
227
285
response : Jsont.json option;
228
286
unknown : Unknown.t;
229
287
}
230
288
231
289
type error = {
232
-
subtype : [`Error];
290
+
subtype : [ `Error ];
233
291
request_id : string;
234
292
error : string;
235
293
unknown : Unknown.t;
236
294
}
237
295
238
-
type t =
239
-
| Success of success
240
-
| Error of error
296
+
type t = Success of success | Error of error
241
297
242
298
let success ~request_id ?response ?(unknown = Unknown.empty) () =
243
-
Success {
244
-
subtype = `Success;
245
-
request_id;
246
-
response;
247
-
unknown;
248
-
}
299
+
Success { subtype = `Success; request_id; response; unknown }
249
300
250
301
let error ~request_id ~error ?(unknown = Unknown.empty) () =
251
-
Error {
252
-
subtype = `Error;
253
-
request_id;
254
-
error;
255
-
unknown;
256
-
}
302
+
Error { subtype = `Error; request_id; error; unknown }
257
303
258
304
(* Individual record codecs *)
259
305
let success_jsont : success Jsont.t =
···
261
307
{ subtype = `Success; request_id; response; unknown }
262
308
in
263
309
Jsont.Object.map ~kind:"Success" make
264
-
|> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun (r : success) -> r.request_id)
265
-
|> Jsont.Object.opt_mem "response" Jsont.json ~enc:(fun (r : success) -> r.response)
266
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : success) -> r.unknown)
310
+
|> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun (r : success) ->
311
+
r.request_id)
312
+
|> Jsont.Object.opt_mem "response" Jsont.json ~enc:(fun (r : success) ->
313
+
r.response)
314
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : success) ->
315
+
r.unknown)
267
316
|> Jsont.Object.finish
268
317
269
318
let error_jsont : error Jsont.t =
···
271
320
{ subtype = `Error; request_id; error; unknown }
272
321
in
273
322
Jsont.Object.map ~kind:"Error" make
274
-
|> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun (r : error) -> r.request_id)
323
+
|> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun (r : error) ->
324
+
r.request_id)
275
325
|> Jsont.Object.mem "error" Jsont.string ~enc:(fun (r : error) -> r.error)
276
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : error) -> r.unknown)
326
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : error) ->
327
+
r.unknown)
277
328
|> Jsont.Object.finish
278
329
279
330
(* Main variant codec using subtype discriminator *)
280
331
let jsont : t Jsont.t =
281
-
let case_success = Jsont.Object.Case.map "success" success_jsont ~dec:(fun v -> Success v) in
282
-
let case_error = Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v) in
332
+
let case_success =
333
+
Jsont.Object.Case.map "success" success_jsont ~dec:(fun v -> Success v)
334
+
in
335
+
let case_error =
336
+
Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
337
+
in
283
338
284
339
let enc_case = function
285
340
| Success v -> Jsont.Object.Case.value case_success v
286
341
| Error v -> Jsont.Object.Case.value case_error v
287
342
in
288
343
289
-
let cases = Jsont.Object.Case.[
290
-
make case_success;
291
-
make case_error;
292
-
] in
344
+
let cases = Jsont.Object.Case.[ make case_success; make case_error ] in
293
345
294
346
Jsont.Object.map ~kind:"Response" Fun.id
295
347
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
296
-
~tag_to_string:Fun.id ~tag_compare:String.compare
348
+
~tag_to_string:Fun.id ~tag_compare:String.compare
297
349
|> Jsont.Object.finish
298
350
end
299
351
300
352
type control_request = {
301
-
type_ : [`Control_request];
353
+
type_ : [ `Control_request ];
302
354
request_id : string;
303
355
request : Request.t;
304
356
unknown : Unknown.t;
305
357
}
306
358
307
359
type control_response = {
308
-
type_ : [`Control_response];
360
+
type_ : [ `Control_response ];
309
361
response : Response.t;
310
362
unknown : Unknown.t;
311
363
}
312
364
313
-
type t =
314
-
| Request of control_request
315
-
| Response of control_response
365
+
type t = Request of control_request | Response of control_response
316
366
317
367
let create_request ~request_id ~request ?(unknown = Unknown.empty) () =
318
-
Request {
319
-
type_ = `Control_request;
320
-
request_id;
321
-
request;
322
-
unknown;
323
-
}
368
+
Request { type_ = `Control_request; request_id; request; unknown }
324
369
325
370
let create_response ~response ?(unknown = Unknown.empty) () =
326
-
Response {
327
-
type_ = `Control_response;
328
-
response;
329
-
unknown;
330
-
}
371
+
Response { type_ = `Control_response; response; unknown }
331
372
332
373
(* Individual record codecs *)
333
374
let control_request_jsont : control_request Jsont.t =
···
335
376
{ type_ = `Control_request; request_id; request; unknown }
336
377
in
337
378
Jsont.Object.map ~kind:"ControlRequest" make
338
-
|> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun (r : control_request) -> r.request_id)
339
-
|> Jsont.Object.mem "request" Request.jsont ~enc:(fun (r : control_request) -> r.request)
340
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : control_request) -> r.unknown)
379
+
|> Jsont.Object.mem "request_id" Jsont.string
380
+
~enc:(fun (r : control_request) -> r.request_id)
381
+
|> Jsont.Object.mem "request" Request.jsont ~enc:(fun (r : control_request) ->
382
+
r.request)
383
+
|> Jsont.Object.keep_unknown Jsont.json_mems
384
+
~enc:(fun (r : control_request) -> r.unknown)
341
385
|> Jsont.Object.finish
342
386
343
387
let control_response_jsont : control_response Jsont.t =
···
345
389
{ type_ = `Control_response; response; unknown }
346
390
in
347
391
Jsont.Object.map ~kind:"ControlResponse" make
348
-
|> Jsont.Object.mem "response" Response.jsont ~enc:(fun (r : control_response) -> r.response)
349
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : control_response) -> r.unknown)
392
+
|> Jsont.Object.mem "response" Response.jsont
393
+
~enc:(fun (r : control_response) -> r.response)
394
+
|> Jsont.Object.keep_unknown Jsont.json_mems
395
+
~enc:(fun (r : control_response) -> r.unknown)
350
396
|> Jsont.Object.finish
351
397
352
398
(* Main variant codec using type discriminator *)
353
399
let jsont : t Jsont.t =
354
-
let case_request = Jsont.Object.Case.map "control_request" control_request_jsont ~dec:(fun v -> Request v) in
355
-
let case_response = Jsont.Object.Case.map "control_response" control_response_jsont ~dec:(fun v -> Response v) in
400
+
let case_request =
401
+
Jsont.Object.Case.map "control_request" control_request_jsont ~dec:(fun v ->
402
+
Request v)
403
+
in
404
+
let case_response =
405
+
Jsont.Object.Case.map "control_response" control_response_jsont
406
+
~dec:(fun v -> Response v)
407
+
in
356
408
357
409
let enc_case = function
358
410
| Request v -> Jsont.Object.Case.value case_request v
359
411
| Response v -> Jsont.Object.Case.value case_response v
360
412
in
361
413
362
-
let cases = Jsont.Object.Case.[
363
-
make case_request;
364
-
make case_response;
365
-
] in
414
+
let cases = Jsont.Object.Case.[ make case_request; make case_response ] in
366
415
367
416
Jsont.Object.map ~kind:"Control" Fun.id
368
417
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
369
-
~tag_to_string:Fun.id ~tag_compare:String.compare
418
+
~tag_to_string:Fun.id ~tag_compare:String.compare
370
419
|> Jsont.Object.finish
371
420
372
421
let log_request req =
373
-
Log.debug (fun m -> m "SDK control request: %a" (Jsont.pp_value Request.jsont ()) req)
422
+
Log.debug (fun m ->
423
+
m "SDK control request: %a" (Jsont.pp_value Request.jsont ()) req)
374
424
375
425
let log_response resp =
376
-
Log.debug (fun m -> m "SDK control response: %a" (Jsont.pp_value Response.jsont ()) resp)
426
+
Log.debug (fun m ->
427
+
m "SDK control response: %a" (Jsont.pp_value Response.jsont ()) resp)
377
428
378
429
(** Server information *)
379
430
module Server_info = struct
···
385
436
unknown : Unknown.t;
386
437
}
387
438
388
-
let create ~version ~capabilities ~commands ~output_styles ?(unknown = Unknown.empty) () =
439
+
let create ~version ~capabilities ~commands ~output_styles
440
+
?(unknown = Unknown.empty) () =
389
441
{ version; capabilities; commands; output_styles; unknown }
390
442
391
443
let version t = t.version
···
395
447
let unknown t = t.unknown
396
448
397
449
let jsont : t Jsont.t =
398
-
let make version capabilities commands output_styles (unknown : Unknown.t) : t =
450
+
let make version capabilities commands output_styles (unknown : Unknown.t) :
451
+
t =
399
452
{ version; capabilities; commands; output_styles; unknown }
400
453
in
401
454
Jsont.Object.map ~kind:"ServerInfo" make
402
455
|> Jsont.Object.mem "version" Jsont.string ~enc:(fun (r : t) -> r.version)
403
-
|> Jsont.Object.mem "capabilities" (Jsont.list Jsont.string) ~enc:(fun (r : t) -> r.capabilities) ~dec_absent:[]
404
-
|> Jsont.Object.mem "commands" (Jsont.list Jsont.string) ~enc:(fun (r : t) -> r.commands) ~dec_absent:[]
405
-
|> Jsont.Object.mem "outputStyles" (Jsont.list Jsont.string) ~enc:(fun (r : t) -> r.output_styles) ~dec_absent:[]
456
+
|> Jsont.Object.mem "capabilities" (Jsont.list Jsont.string)
457
+
~enc:(fun (r : t) -> r.capabilities)
458
+
~dec_absent:[]
459
+
|> Jsont.Object.mem "commands" (Jsont.list Jsont.string)
460
+
~enc:(fun (r : t) -> r.commands)
461
+
~dec_absent:[]
462
+
|> Jsont.Object.mem "outputStyles" (Jsont.list Jsont.string)
463
+
~enc:(fun (r : t) -> r.output_styles)
464
+
~dec_absent:[]
406
465
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : t) -> r.unknown)
407
466
|> Jsont.Object.finish
408
-
end
467
+
end
+73
-74
lib/sdk_control.mli
+73
-74
lib/sdk_control.mli
···
10
10
11
11
{2 Protocol Overview}
12
12
13
-
The SDK control protocol is a JSON-based request/response protocol that
14
-
runs alongside the main message stream. It enables:
13
+
The SDK control protocol is a JSON-based request/response protocol that runs
14
+
alongside the main message stream. It enables:
15
15
16
-
1. {b Callbacks}: Claude asks the SDK for permission or hook execution
17
-
2. {b Control}: SDK changes Claude's behavior dynamically
18
-
3. {b Introspection}: SDK queries server metadata
16
+
1. {b Callbacks}: Claude asks the SDK for permission or hook execution 2.
17
+
{b Control}: SDK changes Claude's behavior dynamically 3. {b Introspection}:
18
+
SDK queries server metadata
19
19
20
20
{2 Request/Response Flow}
21
21
···
51
51
See {!Client.set_permission_mode}, {!Client.set_model}, and
52
52
{!Client.get_server_info} for high-level APIs that use this protocol. *)
53
53
54
-
(** The log source for SDK control operations *)
55
54
val src : Logs.Src.t
55
+
(** The log source for SDK control operations *)
56
56
57
57
(** {1 Request Types} *)
58
58
59
59
module Request : sig
60
60
(** SDK control request types. *)
61
61
62
-
type interrupt = {
63
-
subtype : [`Interrupt];
64
-
unknown : Unknown.t;
65
-
}
62
+
type interrupt = { subtype : [ `Interrupt ]; unknown : Unknown.t }
66
63
(** Interrupt request to stop execution. *)
67
64
68
65
type permission = {
69
-
subtype : [`Can_use_tool];
66
+
subtype : [ `Can_use_tool ];
70
67
tool_name : string;
71
68
input : Jsont.json;
72
69
permission_suggestions : Permissions.Update.t list option;
···
76
73
(** Permission request for tool usage. *)
77
74
78
75
type initialize = {
79
-
subtype : [`Initialize];
80
-
hooks : (string * Jsont.json) list option; (* Hook event to configuration *)
76
+
subtype : [ `Initialize ];
77
+
hooks : (string * Jsont.json) list option; (* Hook event to configuration *)
81
78
unknown : Unknown.t;
82
79
}
83
80
(** Initialize request with optional hook configuration. *)
84
81
85
82
type set_permission_mode = {
86
-
subtype : [`Set_permission_mode];
83
+
subtype : [ `Set_permission_mode ];
87
84
mode : Permissions.Mode.t;
88
85
unknown : Unknown.t;
89
86
}
90
87
(** Request to change permission mode. *)
91
88
92
89
type hook_callback = {
93
-
subtype : [`Hook_callback];
90
+
subtype : [ `Hook_callback ];
94
91
callback_id : string;
95
92
input : Jsont.json;
96
93
tool_use_id : string option;
···
99
96
(** Hook callback request. *)
100
97
101
98
type mcp_message = {
102
-
subtype : [`Mcp_message];
99
+
subtype : [ `Mcp_message ];
103
100
server_name : string;
104
101
message : Jsont.json;
105
102
unknown : Unknown.t;
···
107
104
(** MCP server message request. *)
108
105
109
106
type set_model = {
110
-
subtype : [`Set_model];
107
+
subtype : [ `Set_model ];
111
108
model : string;
112
109
unknown : Unknown.t;
113
110
}
114
111
(** Request to change the AI model. *)
115
112
116
-
type get_server_info = {
117
-
subtype : [`Get_server_info];
118
-
unknown : Unknown.t;
119
-
}
113
+
type get_server_info = { subtype : [ `Get_server_info ]; unknown : Unknown.t }
120
114
(** Request to get server information. *)
121
115
122
116
type t =
···
128
122
| Mcp_message of mcp_message
129
123
| Set_model of set_model
130
124
| Get_server_info of get_server_info
131
-
(** The type of SDK control requests. *)
125
+
(** The type of SDK control requests. *)
132
126
133
127
val interrupt : ?unknown:Unknown.t -> unit -> t
134
128
(** [interrupt ?unknown ()] creates an interrupt request. *)
···
139
133
?permission_suggestions:Permissions.Update.t list ->
140
134
?blocked_path:string ->
141
135
?unknown:Unknown.t ->
142
-
unit -> t
143
-
(** [permission ~tool_name ~input ?permission_suggestions ?blocked_path ?unknown ()]
144
-
creates a permission request. *)
136
+
unit ->
137
+
t
138
+
(** [permission ~tool_name ~input ?permission_suggestions ?blocked_path
139
+
?unknown ()] creates a permission request. *)
145
140
146
-
val initialize : ?hooks:(string * Jsont.json) list -> ?unknown:Unknown.t -> unit -> t
141
+
val initialize :
142
+
?hooks:(string * Jsont.json) list -> ?unknown:Unknown.t -> unit -> t
147
143
(** [initialize ?hooks ?unknown ()] creates an initialize request. *)
148
144
149
-
val set_permission_mode : mode:Permissions.Mode.t -> ?unknown:Unknown.t -> unit -> t
150
-
(** [set_permission_mode ~mode ?unknown] creates a permission mode change request. *)
145
+
val set_permission_mode :
146
+
mode:Permissions.Mode.t -> ?unknown:Unknown.t -> unit -> t
147
+
(** [set_permission_mode ~mode ?unknown] creates a permission mode change
148
+
request. *)
151
149
152
150
val hook_callback :
153
151
callback_id:string ->
154
152
input:Jsont.json ->
155
153
?tool_use_id:string ->
156
154
?unknown:Unknown.t ->
157
-
unit -> t
158
-
(** [hook_callback ~callback_id ~input ?tool_use_id ?unknown ()] creates a hook callback request. *)
155
+
unit ->
156
+
t
157
+
(** [hook_callback ~callback_id ~input ?tool_use_id ?unknown ()] creates a
158
+
hook callback request. *)
159
159
160
-
val mcp_message : server_name:string -> message:Jsont.json -> ?unknown:Unknown.t -> unit -> t
161
-
(** [mcp_message ~server_name ~message ?unknown] creates an MCP message request. *)
160
+
val mcp_message :
161
+
server_name:string -> message:Jsont.json -> ?unknown:Unknown.t -> unit -> t
162
+
(** [mcp_message ~server_name ~message ?unknown] creates an MCP message
163
+
request. *)
162
164
163
165
val set_model : model:string -> ?unknown:Unknown.t -> unit -> t
164
166
(** [set_model ~model ?unknown] creates a model change request. *)
···
167
169
(** [get_server_info ?unknown ()] creates a server info request. *)
168
170
169
171
val jsont : t Jsont.t
170
-
(** [jsont] is the jsont codec for requests.
171
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
172
+
(** [jsont] is the jsont codec for requests. Use [Jsont.pp_value jsont ()] for
173
+
pretty-printing. *)
172
174
end
173
175
174
176
(** {1 Response Types} *)
···
177
179
(** SDK control response types. *)
178
180
179
181
type success = {
180
-
subtype : [`Success];
182
+
subtype : [ `Success ];
181
183
request_id : string;
182
184
response : Jsont.json option;
183
185
unknown : Unknown.t;
···
185
187
(** Successful response. *)
186
188
187
189
type error = {
188
-
subtype : [`Error];
190
+
subtype : [ `Error ];
189
191
request_id : string;
190
192
error : string;
191
193
unknown : Unknown.t;
···
194
196
195
197
type t =
196
198
| Success of success
197
-
| Error of error
198
-
(** The type of SDK control responses. *)
199
+
| Error of error (** The type of SDK control responses. *)
199
200
200
-
val success : request_id:string -> ?response:Jsont.json -> ?unknown:Unknown.t -> unit -> t
201
+
val success :
202
+
request_id:string -> ?response:Jsont.json -> ?unknown:Unknown.t -> unit -> t
201
203
(** [success ~request_id ?response ?unknown ()] creates a success response. *)
202
204
203
-
val error : request_id:string -> error:string -> ?unknown:Unknown.t -> unit -> t
205
+
val error :
206
+
request_id:string -> error:string -> ?unknown:Unknown.t -> unit -> t
204
207
(** [error ~request_id ~error ?unknown] creates an error response. *)
205
208
206
209
val jsont : t Jsont.t
207
-
(** [jsont] is the jsont codec for responses.
208
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
210
+
(** [jsont] is the jsont codec for responses. Use [Jsont.pp_value jsont ()]
211
+
for pretty-printing. *)
209
212
end
210
213
211
214
(** {1 Control Messages} *)
212
215
213
216
type control_request = {
214
-
type_ : [`Control_request];
217
+
type_ : [ `Control_request ];
215
218
request_id : string;
216
219
request : Request.t;
217
220
unknown : Unknown.t;
···
219
222
(** Control request message. *)
220
223
221
224
type control_response = {
222
-
type_ : [`Control_response];
225
+
type_ : [ `Control_response ];
223
226
response : Response.t;
224
227
unknown : Unknown.t;
225
228
}
226
229
(** Control response message. *)
227
230
228
231
val control_response_jsont : control_response Jsont.t
229
-
(** [control_response_jsont] is the jsont codec for control response messages. *)
232
+
(** [control_response_jsont] is the jsont codec for control response messages.
233
+
*)
230
234
231
235
type t =
232
236
| Request of control_request
233
-
| Response of control_response
234
-
(** The type of SDK control messages. *)
237
+
| Response of control_response (** The type of SDK control messages. *)
235
238
236
-
val create_request : request_id:string -> request:Request.t -> ?unknown:Unknown.t -> unit -> t
237
-
(** [create_request ~request_id ~request ?unknown ()] creates a control request message. *)
239
+
val create_request :
240
+
request_id:string -> request:Request.t -> ?unknown:Unknown.t -> unit -> t
241
+
(** [create_request ~request_id ~request ?unknown ()] creates a control request
242
+
message. *)
238
243
239
244
val create_response : response:Response.t -> ?unknown:Unknown.t -> unit -> t
240
-
(** [create_response ~response ?unknown ()] creates a control response message. *)
245
+
(** [create_response ~response ?unknown ()] creates a control response message.
246
+
*)
241
247
242
248
val jsont : t Jsont.t
243
-
(** [jsont] is the jsont codec for control messages.
244
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
249
+
(** [jsont] is the jsont codec for control messages. Use
250
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
245
251
246
252
(** {1 Logging} *)
247
253
···
253
259
254
260
(** {1 Server Information}
255
261
256
-
Server information provides metadata about the Claude CLI server,
257
-
including version, capabilities, available commands, and output styles.
262
+
Server information provides metadata about the Claude CLI server, including
263
+
version, capabilities, available commands, and output styles.
258
264
259
265
{2 Use Cases}
260
266
···
267
273
268
274
{[
269
275
let info = Client.get_server_info client in
270
-
Printf.printf "Claude CLI version: %s\n"
271
-
(Server_info.version info);
276
+
Printf.printf "Claude CLI version: %s\n" (Server_info.version info);
272
277
273
278
if List.mem "structured-output" (Server_info.capabilities info) then
274
279
Printf.printf "Structured output is supported\n"
275
-
else
276
-
Printf.printf "Structured output not available\n";
280
+
else Printf.printf "Structured output not available\n"
277
281
]} *)
278
282
279
283
module Server_info : sig
280
284
(** Server information and capabilities. *)
281
285
282
286
type t = {
283
-
version : string;
284
-
(** Server version string (e.g., "2.0.0") *)
285
-
287
+
version : string; (** Server version string (e.g., "2.0.0") *)
286
288
capabilities : string list;
287
-
(** Available server capabilities (e.g., "hooks", "structured-output") *)
288
-
289
-
commands : string list;
290
-
(** Available CLI commands *)
291
-
289
+
(** Available server capabilities (e.g., "hooks", "structured-output")
290
+
*)
291
+
commands : string list; (** Available CLI commands *)
292
292
output_styles : string list;
293
-
(** Supported output formats (e.g., "json", "stream-json") *)
294
-
295
-
unknown : Unknown.t;
296
-
(** Unknown fields for forward compatibility *)
293
+
(** Supported output formats (e.g., "json", "stream-json") *)
294
+
unknown : Unknown.t; (** Unknown fields for forward compatibility *)
297
295
}
298
296
(** Server metadata and capabilities.
299
297
···
307
305
?unknown:Unknown.t ->
308
306
unit ->
309
307
t
310
-
(** [create ~version ~capabilities ~commands ~output_styles ?unknown ()] creates server info. *)
308
+
(** [create ~version ~capabilities ~commands ~output_styles ?unknown ()]
309
+
creates server info. *)
311
310
312
311
val version : t -> string
313
312
(** [version t] returns the server version. *)
···
325
324
(** [unknown t] returns the unknown fields. *)
326
325
327
326
val jsont : t Jsont.t
328
-
(** [jsont] is the jsont codec for server info.
329
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
330
-
end
327
+
(** [jsont] is the jsont codec for server info. Use [Jsont.pp_value jsont ()]
328
+
for pretty-printing. *)
329
+
end
+5
-7
lib/structured_output.ml
+5
-7
lib/structured_output.ml
···
1
1
let src = Logs.Src.create "claude.structured_output" ~doc:"Structured output"
2
+
2
3
module Log = (val Logs.src_log src : Logs.LOG)
3
4
4
-
type t = {
5
-
json_schema : Jsont.json;
6
-
}
5
+
type t = { json_schema : Jsont.json }
7
6
8
7
let json_to_string json =
9
8
match Jsont_bytesrw.encode_string' Jsont.json json with
···
11
10
| Error err -> failwith (Jsont.Error.to_string err)
12
11
13
12
let of_json_schema schema =
14
-
Log.debug (fun m -> m "Created output format from JSON schema: %s"
15
-
(json_to_string schema));
13
+
Log.debug (fun m ->
14
+
m "Created output format from JSON schema: %s" (json_to_string schema));
16
15
{ json_schema = schema }
17
16
18
17
let json_schema t = t.json_schema
19
18
20
19
(* Codec for serializing structured output format *)
21
20
let jsont : t Jsont.t =
22
-
Jsont.Object.map ~kind:"StructuredOutput"
23
-
(fun json_schema -> {json_schema})
21
+
Jsont.Object.map ~kind:"StructuredOutput" (fun json_schema -> { json_schema })
24
22
|> Jsont.Object.mem "jsonSchema" Jsont.json ~enc:(fun t -> t.json_schema)
25
23
|> Jsont.Object.finish
26
24
+27
-35
lib/structured_output.mli
+27
-35
lib/structured_output.mli
···
7
7
8
8
{2 Overview}
9
9
10
-
Structured outputs ensure that Claude's responses conform to a specific
11
-
JSON schema, making it easier to parse and use the results programmatically.
12
-
This is particularly useful for:
10
+
Structured outputs ensure that Claude's responses conform to a specific JSON
11
+
schema, making it easier to parse and use the results programmatically. This
12
+
is particularly useful for:
13
13
14
14
- Extracting structured data from unstructured text
15
15
- Building APIs that require consistent JSON responses
···
42
42
43
43
{3 Helper Functions for Building Schemas}
44
44
45
-
For complex schemas, you can use helper functions to make construction easier:
45
+
For complex schemas, you can use helper functions to make construction
46
+
easier:
46
47
{[
47
-
let json_object fields =
48
-
Jsont.Object (fields, Jsont.Meta.none)
49
-
50
-
let json_string s =
51
-
Jsont.String (s, Jsont.Meta.none)
52
-
53
-
let json_array items =
54
-
Jsont.Array (items, Jsont.Meta.none)
55
-
56
-
let json_field name value =
57
-
((name, Jsont.Meta.none), value)
48
+
let json_object fields = Jsont.Object (fields, Jsont.Meta.none)
49
+
let json_string s = Jsont.String (s, Jsont.Meta.none)
50
+
let json_array items = Jsont.Array (items, Jsont.Meta.none)
51
+
let json_field name value = ((name, Jsont.Meta.none), value)
58
52
59
53
let person_schema =
60
-
json_object [
61
-
json_field "type" (json_string "object");
62
-
json_field "properties" (json_object [
63
-
json_field "name" (json_object [
64
-
json_field "type" (json_string "string")
65
-
]);
66
-
json_field "age" (json_object [
67
-
json_field "type" (json_string "integer")
68
-
]);
69
-
]);
70
-
json_field "required" (json_array [
71
-
json_string "name";
72
-
json_string "age"
73
-
])
74
-
]
54
+
json_object
55
+
[
56
+
json_field "type" (json_string "object");
57
+
json_field "properties"
58
+
(json_object
59
+
[
60
+
json_field "name"
61
+
(json_object [ json_field "type" (json_string "string") ]);
62
+
json_field "age"
63
+
(json_object [ json_field "type" (json_string "integer") ]);
64
+
]);
65
+
json_field "required"
66
+
(json_array [ json_string "name"; json_string "age" ]);
67
+
]
75
68
76
69
let format = Structured_output.of_json_schema person_schema
77
70
]}
···
113
106
@see <https://json-schema.org/> JSON Schema specification
114
107
@see <https://erratique.ch/software/jsont> jsont documentation *)
115
108
116
-
(** The log source for structured output operations *)
117
109
val src : Logs.Src.t
110
+
(** The log source for structured output operations *)
118
111
119
112
(** {1 Output Format Configuration} *)
120
113
···
159
152
Internal use for encoding/decoding with the CLI. *)
160
153
161
154
val to_json : t -> Jsont.json
162
-
(** [to_json t] converts the output format to its JSON representation.
163
-
Internal use only. *)
155
+
(** [to_json t] converts the output format to its JSON representation. Internal
156
+
use only. *)
164
157
165
158
val of_json : Jsont.json -> t
166
-
(** [of_json json] parses an output format from JSON.
167
-
Internal use only.
159
+
(** [of_json json] parses an output format from JSON. Internal use only.
168
160
@raise Invalid_argument if the JSON is not a valid output format. *)
+129
-84
lib/transport.ml
+129
-84
lib/transport.ml
···
1
1
open Eio.Std
2
2
3
3
let src = Logs.Src.create "claude.transport" ~doc:"Claude transport layer"
4
+
4
5
module Log = (val Logs.src_log src : Logs.LOG)
5
6
6
7
exception CLI_not_found of string
···
12
13
type t = {
13
14
process : process;
14
15
stdin : Eio.Flow.sink_ty r;
15
-
stdin_close : [`Close | `Flow] r;
16
+
stdin_close : [ `Close | `Flow ] r;
16
17
stdout : Eio.Buf_read.t;
17
18
}
18
19
···
22
23
| Options.Local -> "local"
23
24
24
25
let build_command ~claude_path ~options =
25
-
let cmd = [claude_path; "--output-format"; "stream-json"; "--verbose"] in
26
+
let cmd = [ claude_path; "--output-format"; "stream-json"; "--verbose" ] in
26
27
27
-
let cmd = match Options.system_prompt options with
28
-
| Some prompt -> cmd @ ["--system-prompt"; prompt]
28
+
let cmd =
29
+
match Options.system_prompt options with
30
+
| Some prompt -> cmd @ [ "--system-prompt"; prompt ]
29
31
| None -> cmd
30
32
in
31
33
32
-
let cmd = match Options.append_system_prompt options with
33
-
| Some prompt -> cmd @ ["--append-system-prompt"; prompt]
34
+
let cmd =
35
+
match Options.append_system_prompt options with
36
+
| Some prompt -> cmd @ [ "--append-system-prompt"; prompt ]
34
37
| None -> cmd
35
38
in
36
39
37
-
let cmd = match Options.allowed_tools options with
40
+
let cmd =
41
+
match Options.allowed_tools options with
38
42
| [] -> cmd
39
-
| tools -> cmd @ ["--allowedTools"; String.concat "," tools]
43
+
| tools -> cmd @ [ "--allowedTools"; String.concat "," tools ]
40
44
in
41
45
42
-
let cmd = match Options.disallowed_tools options with
46
+
let cmd =
47
+
match Options.disallowed_tools options with
43
48
| [] -> cmd
44
-
| tools -> cmd @ ["--disallowedTools"; String.concat "," tools]
49
+
| tools -> cmd @ [ "--disallowedTools"; String.concat "," tools ]
45
50
in
46
51
47
-
let cmd = match Options.model options with
48
-
| Some model -> cmd @ ["--model"; Model.to_string model]
52
+
let cmd =
53
+
match Options.model options with
54
+
| Some model -> cmd @ [ "--model"; Model.to_string model ]
49
55
| None -> cmd
50
56
in
51
57
52
-
let cmd = match Options.permission_mode options with
58
+
let cmd =
59
+
match Options.permission_mode options with
53
60
| Some mode ->
54
61
let mode_str = Permissions.Mode.to_string mode in
55
-
cmd @ ["--permission-mode"; mode_str]
62
+
cmd @ [ "--permission-mode"; mode_str ]
56
63
| None -> cmd
57
64
in
58
65
59
-
let cmd = match Options.permission_prompt_tool_name options with
60
-
| Some tool_name -> cmd @ ["--permission-prompt-tool"; tool_name]
66
+
let cmd =
67
+
match Options.permission_prompt_tool_name options with
68
+
| Some tool_name -> cmd @ [ "--permission-prompt-tool"; tool_name ]
61
69
| None -> cmd
62
70
in
63
71
64
72
(* Advanced configuration options *)
65
-
let cmd = match Options.max_budget_usd options with
66
-
| Some budget -> cmd @ ["--max-budget-usd"; Float.to_string budget]
73
+
let cmd =
74
+
match Options.max_budget_usd options with
75
+
| Some budget -> cmd @ [ "--max-budget-usd"; Float.to_string budget ]
67
76
| None -> cmd
68
77
in
69
78
70
-
let cmd = match Options.fallback_model options with
71
-
| Some model -> cmd @ ["--fallback-model"; Model.to_string model]
79
+
let cmd =
80
+
match Options.fallback_model options with
81
+
| Some model -> cmd @ [ "--fallback-model"; Model.to_string model ]
72
82
| None -> cmd
73
83
in
74
84
75
-
let cmd = match Options.setting_sources options with
85
+
let cmd =
86
+
match Options.setting_sources options with
76
87
| Some sources ->
77
-
let sources_str = String.concat "," (List.map setting_source_to_string sources) in
78
-
cmd @ ["--setting-sources"; sources_str]
88
+
let sources_str =
89
+
String.concat "," (List.map setting_source_to_string sources)
90
+
in
91
+
cmd @ [ "--setting-sources"; sources_str ]
79
92
| None -> cmd
80
93
in
81
94
82
95
(* Add JSON Schema if specified *)
83
-
let cmd = match Options.output_format options with
96
+
let cmd =
97
+
match Options.output_format options with
84
98
| Some format ->
85
99
let schema = Structured_output.json_schema format in
86
-
let schema_str = match Jsont_bytesrw.encode_string' Jsont.json schema with
100
+
let schema_str =
101
+
match Jsont_bytesrw.encode_string' Jsont.json schema with
87
102
| Ok s -> s
88
103
| Error err -> failwith (Jsont.Error.to_string err)
89
104
in
90
-
cmd @ ["--json-schema"; schema_str]
105
+
cmd @ [ "--json-schema"; schema_str ]
91
106
| None -> cmd
92
107
in
93
108
94
109
(* Use streaming input mode *)
95
-
cmd @ ["--input-format"; "stream-json"]
110
+
cmd @ [ "--input-format"; "stream-json" ]
96
111
97
112
let create ~sw ~process_mgr ~options () =
98
113
let claude_path = "claude" in
99
114
let cmd = build_command ~claude_path ~options in
100
-
115
+
101
116
(* Build environment - preserve essential vars for Claude config/auth access *)
102
117
let home = try Unix.getenv "HOME" with Not_found -> "/tmp" in
103
118
let path = try Unix.getenv "PATH" with Not_found -> "/usr/bin:/bin" in
104
-
119
+
105
120
(* Preserve other potentially important environment variables *)
106
-
let preserve_vars = [
107
-
"USER"; "LOGNAME"; "SHELL"; "TERM";
108
-
"XDG_CONFIG_HOME"; "XDG_DATA_HOME"; "XDG_CACHE_HOME";
109
-
"ANTHROPIC_API_KEY"; "CLAUDE_API_KEY" (* In case API key is set via env *)
110
-
] in
111
-
112
-
let preserved = List.filter_map (fun var ->
113
-
try Some (Printf.sprintf "%s=%s" var (Unix.getenv var))
114
-
with Not_found -> None
115
-
) preserve_vars in
116
-
117
-
let base_env = [
118
-
Printf.sprintf "HOME=%s" home;
119
-
Printf.sprintf "PATH=%s" path;
120
-
"CLAUDE_CODE_ENTRYPOINT=sdk-ocaml";
121
-
] @ preserved in
122
-
123
-
let custom_env = List.map (fun (k, v) -> Printf.sprintf "%s=%s" k v) (Options.env options) in
121
+
let preserve_vars =
122
+
[
123
+
"USER";
124
+
"LOGNAME";
125
+
"SHELL";
126
+
"TERM";
127
+
"XDG_CONFIG_HOME";
128
+
"XDG_DATA_HOME";
129
+
"XDG_CACHE_HOME";
130
+
"ANTHROPIC_API_KEY";
131
+
"CLAUDE_API_KEY" (* In case API key is set via env *);
132
+
]
133
+
in
134
+
135
+
let preserved =
136
+
List.filter_map
137
+
(fun var ->
138
+
try Some (Printf.sprintf "%s=%s" var (Unix.getenv var))
139
+
with Not_found -> None)
140
+
preserve_vars
141
+
in
142
+
143
+
let base_env =
144
+
[
145
+
Printf.sprintf "HOME=%s" home;
146
+
Printf.sprintf "PATH=%s" path;
147
+
"CLAUDE_CODE_ENTRYPOINT=sdk-ocaml";
148
+
]
149
+
@ preserved
150
+
in
151
+
152
+
let custom_env =
153
+
List.map (fun (k, v) -> Printf.sprintf "%s=%s" k v) (Options.env options)
154
+
in
124
155
let env = Array.of_list (base_env @ custom_env) in
125
156
Log.debug (fun m -> m "Environment: HOME=%s, PATH=%s" home path);
126
-
Log.info (fun m -> m "Full environment variables: %s" (String.concat ", " (Array.to_list env)));
127
-
157
+
Log.info (fun m ->
158
+
m "Full environment variables: %s"
159
+
(String.concat ", " (Array.to_list env)));
160
+
128
161
let stdin_r, stdin_w = Eio.Process.pipe ~sw process_mgr in
129
162
let stdout_r, stdout_w = Eio.Process.pipe ~sw process_mgr in
130
163
let stderr_r, stderr_w = Eio.Process.pipe ~sw process_mgr in
131
164
(* Close stderr pipes - we don't need them *)
132
165
Eio.Flow.close stderr_r;
133
166
Eio.Flow.close stderr_w;
134
-
135
-
let process =
167
+
168
+
let process =
136
169
try
137
-
Log.info (fun m -> m "Spawning claude with command: %s" (String.concat " " cmd));
170
+
Log.info (fun m ->
171
+
m "Spawning claude with command: %s" (String.concat " " cmd));
138
172
Log.info (fun m -> m "Command arguments breakdown:");
139
-
List.iteri (fun i arg ->
140
-
Log.info (fun m -> m " [%d]: %s" i arg)
141
-
) cmd;
142
-
Eio.Process.spawn ~sw process_mgr
143
-
~env
173
+
List.iteri (fun i arg -> Log.info (fun m -> m " [%d]: %s" i arg)) cmd;
174
+
Eio.Process.spawn ~sw process_mgr ~env
144
175
~stdin:(stdin_r :> Eio.Flow.source_ty r)
145
176
~stdout:(stdout_w :> Eio.Flow.sink_ty r)
146
-
?cwd:(Options.cwd options)
147
-
cmd
148
-
with
149
-
| exn ->
150
-
Log.err (fun m -> m "Failed to spawn claude CLI: %s" (Printexc.to_string exn));
151
-
Log.err (fun m -> m "Make sure 'claude' is installed and authenticated");
152
-
Log.err (fun m -> m "You may need to run 'claude login' first");
153
-
raise (CLI_not_found (Printf.sprintf "Failed to spawn claude CLI: %s" (Printexc.to_string exn)))
177
+
?cwd:(Options.cwd options) cmd
178
+
with exn ->
179
+
Log.err (fun m ->
180
+
m "Failed to spawn claude CLI: %s" (Printexc.to_string exn));
181
+
Log.err (fun m -> m "Make sure 'claude' is installed and authenticated");
182
+
Log.err (fun m -> m "You may need to run 'claude login' first");
183
+
raise
184
+
(CLI_not_found
185
+
(Printf.sprintf "Failed to spawn claude CLI: %s"
186
+
(Printexc.to_string exn)))
154
187
in
155
-
188
+
156
189
let stdin = (stdin_w :> Eio.Flow.sink_ty r) in
157
-
let stdin_close = (stdin_w :> [`Close | `Flow] r) in
158
-
let max_size = match Options.max_buffer_size options with
190
+
let stdin_close = (stdin_w :> [ `Close | `Flow ] r) in
191
+
let max_size =
192
+
match Options.max_buffer_size options with
159
193
| Some size -> size
160
-
| None -> 1_000_000 (* Default 1MB *)
194
+
| None -> 1_000_000 (* Default 1MB *)
195
+
in
196
+
let stdout =
197
+
Eio.Buf_read.of_flow ~max_size (stdout_r :> Eio.Flow.source_ty r)
161
198
in
162
-
let stdout = Eio.Buf_read.of_flow ~max_size (stdout_r :> Eio.Flow.source_ty r) in
163
199
164
200
{ process = P process; stdin; stdin_close; stdout }
165
201
166
202
let send t json =
167
-
let data = match Jsont_bytesrw.encode_string' Jsont.json json with
203
+
let data =
204
+
match Jsont_bytesrw.encode_string' Jsont.json json with
168
205
| Ok s -> s
169
206
| Error err -> failwith (Jsont.Error.to_string err)
170
207
in
171
208
Log.debug (fun m -> m "Sending: %s" data);
172
-
try
173
-
Eio.Flow.write t.stdin [Cstruct.of_string (data ^ "\n")]
174
-
with
175
-
| exn ->
176
-
Log.err (fun m -> m "Failed to send message: %s" (Printexc.to_string exn));
177
-
raise (Connection_error (Printf.sprintf "Failed to send message: %s" (Printexc.to_string exn)))
209
+
try Eio.Flow.write t.stdin [ Cstruct.of_string (data ^ "\n") ]
210
+
with exn ->
211
+
Log.err (fun m -> m "Failed to send message: %s" (Printexc.to_string exn));
212
+
raise
213
+
(Connection_error
214
+
(Printf.sprintf "Failed to send message: %s" (Printexc.to_string exn)))
178
215
179
216
let receive_line t =
180
217
try
181
218
match Eio.Buf_read.line t.stdout with
182
-
| line ->
219
+
| line ->
183
220
Log.debug (fun m -> m "Raw JSON: %s" line);
184
221
Some line
185
-
| exception End_of_file ->
222
+
| exception End_of_file ->
186
223
Log.debug (fun m -> m "Received EOF");
187
224
None
188
-
with
189
-
| exn ->
190
-
Log.err (fun m -> m "Failed to receive message: %s" (Printexc.to_string exn));
191
-
raise (Connection_error (Printf.sprintf "Failed to receive message: %s" (Printexc.to_string exn)))
225
+
with exn ->
226
+
Log.err (fun m ->
227
+
m "Failed to receive message: %s" (Printexc.to_string exn));
228
+
raise
229
+
(Connection_error
230
+
(Printf.sprintf "Failed to receive message: %s"
231
+
(Printexc.to_string exn)))
192
232
193
233
(** Wire codec for interrupt response messages. *)
194
234
module Interrupt_wire = struct
···
210
250
|> Jsont.Object.finish
211
251
212
252
let encode () =
213
-
let wire = { type_ = "control_response"; response = { subtype = "interrupt"; request_id = "" } } in
253
+
let wire =
254
+
{
255
+
type_ = "control_response";
256
+
response = { subtype = "interrupt"; request_id = "" };
257
+
}
258
+
in
214
259
match Jsont.Json.encode jsont wire with
215
260
| Ok json -> json
216
261
| Error msg -> failwith ("Interrupt_wire.encode: " ^ msg)
+3
-2
lib/transport.mli
+3
-2
lib/transport.mli
···
1
-
(** The log source for transport operations *)
2
1
val src : Logs.Src.t
2
+
(** The log source for transport operations *)
3
3
4
4
exception CLI_not_found of string
5
5
exception Process_error of string
···
11
11
sw:Eio.Switch.t ->
12
12
process_mgr:_ Eio.Process.mgr ->
13
13
options:Options.t ->
14
-
unit -> t
14
+
unit ->
15
+
t
15
16
16
17
val send : t -> Jsont.json -> unit
17
18
val receive_line : t -> string option
+5
-7
lib/unknown.ml
+5
-7
lib/unknown.ml
···
2
2
3
3
This module provides a type and utilities for preserving unknown/extra
4
4
fields when parsing JSON objects with jsont. Use with
5
-
[Jsont.Object.keep_unknown] to capture fields not explicitly defined
6
-
in your codec. *)
5
+
[Jsont.Object.keep_unknown] to capture fields not explicitly defined in your
6
+
codec. *)
7
7
8
8
type t = Jsont.json
9
9
(** The type of unknown fields - stored as raw JSON. *)
10
10
11
-
let empty = Jsont.Object ([], Jsont.Meta.none)
12
11
(** An empty unknown fields value (empty JSON object). *)
12
+
let empty = Jsont.Object ([], Jsont.Meta.none)
13
13
14
-
let is_empty = function
15
-
| Jsont.Object ([], _) -> true
16
-
| _ -> false
17
14
(** [is_empty t] returns [true] if there are no unknown fields. *)
15
+
let is_empty = function Jsont.Object ([], _) -> true | _ -> false
18
16
17
+
(** Codec for unknown fields. *)
19
18
let jsont = Jsont.json
20
-
(** Codec for unknown fields. *)
+2
-2
lib/unknown.mli
+2
-2
lib/unknown.mli
···
2
2
3
3
This module provides a type and utilities for preserving unknown/extra
4
4
fields when parsing JSON objects with jsont. Use with
5
-
[Jsont.Object.keep_unknown] to capture fields not explicitly defined
6
-
in your codec. *)
5
+
[Jsont.Object.keep_unknown] to capture fields not explicitly defined in your
6
+
codec. *)
7
7
8
8
type t = Jsont.json
9
9
(** The type of unknown fields - stored as raw JSON. *)
+48
-44
test/advanced_config_demo.ml
+48
-44
test/advanced_config_demo.ml
···
21
21
without any user/project/local settings interfering.
22
22
*)
23
23
let ci_cd_config () =
24
-
Options.default
25
-
|> Options.with_no_settings (* Disable all settings loading *)
26
-
|> Options.with_max_budget_usd 0.50 (* 50 cent limit per run *)
27
-
|> Options.with_fallback_model_string "claude-haiku-4" (* Fast fallback *)
24
+
Options.default |> Options.with_no_settings (* Disable all settings loading *)
25
+
|> Options.with_max_budget_usd 0.50 (* 50 cent limit per run *)
26
+
|> Options.with_fallback_model_string "claude-haiku-4" (* Fast fallback *)
28
27
|> Options.with_model_string "claude-sonnet-4-5"
29
28
|> Options.with_permission_mode Permissions.Mode.Bypass_permissions
30
29
···
37
36
Options.default
38
37
|> Options.with_model_string "claude-sonnet-4-5"
39
38
|> Options.with_fallback_model_string "claude-sonnet-3-5"
40
-
|> Options.with_max_budget_usd 10.0 (* $10 limit *)
41
-
|> Options.with_max_buffer_size 5_000_000 (* 5MB buffer for large outputs *)
39
+
|> Options.with_max_budget_usd 10.0 (* $10 limit *)
40
+
|> Options.with_max_buffer_size 5_000_000 (* 5MB buffer for large outputs *)
42
41
43
42
(* Example 3: Development Configuration
44
43
···
46
45
*)
47
46
let dev_config () =
48
47
Options.default
49
-
|> Options.with_setting_sources [Options.User; Options.Project]
50
-
|> Options.with_max_budget_usd 1.0 (* $1 limit for dev testing *)
48
+
|> Options.with_setting_sources [ Options.User; Options.Project ]
49
+
|> Options.with_max_budget_usd 1.0 (* $1 limit for dev testing *)
51
50
|> Options.with_fallback_model_string "claude-haiku-4"
52
51
53
52
(* Example 4: Isolated Test Configuration
···
55
54
For automated testing with no external settings and strict limits.
56
55
*)
57
56
let test_config () =
58
-
Options.default
59
-
|> Options.with_no_settings
60
-
|> Options.with_max_budget_usd 0.10 (* 10 cent limit per test *)
61
-
|> Options.with_model_string "claude-haiku-4" (* Fast, cheap model *)
57
+
Options.default |> Options.with_no_settings
58
+
|> Options.with_max_budget_usd 0.10 (* 10 cent limit per test *)
59
+
|> Options.with_model_string "claude-haiku-4" (* Fast, cheap model *)
62
60
|> Options.with_permission_mode Permissions.Mode.Bypass_permissions
63
-
|> Options.with_max_buffer_size 1_000_000 (* 1MB buffer *)
61
+
|> Options.with_max_buffer_size 1_000_000 (* 1MB buffer *)
64
62
65
63
(* Example 5: Custom Buffer Size Demo
66
64
···
68
66
*)
69
67
let _large_output_config () =
70
68
Options.default
71
-
|> Options.with_max_buffer_size 10_000_000 (* 10MB buffer *)
69
+
|> Options.with_max_buffer_size 10_000_000 (* 10MB buffer *)
72
70
|> Options.with_model_string "claude-sonnet-4-5"
73
71
74
72
(* Helper to run a query with a specific configuration *)
···
78
76
| Some budget -> Printf.printf "Budget limit: $%.2f\n" budget
79
77
| None -> print_endline "Budget limit: None");
80
78
(match Options.fallback_model config with
81
-
| Some model -> Printf.printf "Fallback model: %s\n" (Claude.Model.to_string model)
79
+
| Some model ->
80
+
Printf.printf "Fallback model: %s\n" (Claude.Model.to_string model)
82
81
| None -> print_endline "Fallback model: None");
83
82
(match Options.setting_sources config with
84
83
| Some [] -> print_endline "Settings: Isolated (no settings loaded)"
85
84
| Some sources ->
86
-
let source_str = String.concat ", " (List.map (function
87
-
| Options.User -> "user"
88
-
| Options.Project -> "project"
89
-
| Options.Local -> "local"
90
-
) sources) in
85
+
let source_str =
86
+
String.concat ", "
87
+
(List.map
88
+
(function
89
+
| Options.User -> "user"
90
+
| Options.Project -> "project"
91
+
| Options.Local -> "local")
92
+
sources)
93
+
in
91
94
Printf.printf "Settings: %s\n" source_str
92
95
| None -> print_endline "Settings: Default");
93
96
(match Options.max_buffer_size config with
···
99
102
Client.query client prompt;
100
103
let messages = Client.receive client in
101
104
102
-
Seq.iter (function
103
-
| Message.Assistant msg ->
104
-
List.iter (function
105
-
| Content_block.Text t ->
106
-
Printf.printf "Response: %s\n" (Content_block.Text.text t)
107
-
| _ -> ()
108
-
) (Message.Assistant.content msg)
109
-
| Message.Result result ->
110
-
Printf.printf "\n=== Session Complete ===\n";
111
-
Printf.printf "Duration: %dms\n" (Message.Result.duration_ms result);
112
-
(match Message.Result.total_cost_usd result with
113
-
| Some cost -> Printf.printf "Cost: $%.4f\n" cost
114
-
| None -> ());
115
-
Printf.printf "Turns: %d\n" (Message.Result.num_turns result)
116
-
| _ -> ()
117
-
) messages
105
+
Seq.iter
106
+
(function
107
+
| Message.Assistant msg ->
108
+
List.iter
109
+
(function
110
+
| Content_block.Text t ->
111
+
Printf.printf "Response: %s\n" (Content_block.Text.text t)
112
+
| _ -> ())
113
+
(Message.Assistant.content msg)
114
+
| Message.Result result ->
115
+
Printf.printf "\n=== Session Complete ===\n";
116
+
Printf.printf "Duration: %dms\n" (Message.Result.duration_ms result);
117
+
(match Message.Result.total_cost_usd result with
118
+
| Some cost -> Printf.printf "Cost: $%.4f\n" cost
119
+
| None -> ());
120
+
Printf.printf "Turns: %d\n" (Message.Result.num_turns result)
121
+
| _ -> ())
122
+
messages
118
123
119
124
let main () =
120
125
log_setup ();
···
143
148
print_endline "\n\n### Example 3: Development Configuration ###";
144
149
print_endline "Purpose: Development with user/project settings";
145
150
let config = dev_config () in
146
-
run_query ~sw process_mgr config "What is functional programming? One sentence.";
151
+
run_query ~sw process_mgr config
152
+
"What is functional programming? One sentence.";
147
153
148
154
(* Example: Test configuration *)
149
155
print_endline "\n\n### Example 4: Test Configuration ###";
···
156
162
print_endline "=============================================="
157
163
158
164
let () =
159
-
try
160
-
main ()
161
-
with
162
-
| e ->
163
-
Printf.eprintf "Error: %s\n" (Printexc.to_string e);
164
-
Printexc.print_backtrace stderr;
165
-
exit 1
165
+
try main ()
166
+
with e ->
167
+
Printf.eprintf "Error: %s\n" (Printexc.to_string e);
168
+
Printexc.print_backtrace stderr;
169
+
exit 1
+94
-79
test/camel_jokes.ml
+94
-79
test/camel_jokes.ml
···
1
1
open Eio.Std
2
2
3
3
let src = Logs.Src.create "camel_jokes" ~doc:"Camel joke competition"
4
+
4
5
module Log = (val Logs.src_log src : Logs.LOG)
5
6
6
7
let process_claude_response client name =
7
8
Log.info (fun m -> m "=== %s's Response ===" name);
8
9
let messages = Claude.Client.receive_all client in
9
-
List.iter (fun msg ->
10
-
match msg with
11
-
| Claude.Message.Assistant msg ->
12
-
List.iter (function
13
-
| Claude.Content_block.Text t ->
14
-
let text = Claude.Content_block.Text.text t in
15
-
Log.app (fun m -> m "%s: %s" name text)
16
-
| Claude.Content_block.Tool_use t ->
17
-
Log.debug (fun m -> m "%s using tool: %s" name
18
-
(Claude.Content_block.Tool_use.name t))
19
-
| Claude.Content_block.Thinking t ->
20
-
Log.debug (fun m -> m "%s thinking: %s" name
21
-
(Claude.Content_block.Thinking.thinking t))
22
-
| _ -> ()
23
-
) (Claude.Message.Assistant.content msg);
24
-
Log.debug (fun m -> m "%s using model: %s" name
25
-
(Claude.Message.Assistant.model msg))
26
-
| Claude.Message.Result msg ->
27
-
if Claude.Message.Result.is_error msg then
28
-
Log.err (fun m -> m "Error from %s!" name)
29
-
else
30
-
(match Claude.Message.Result.total_cost_usd msg with
31
-
| Some cost ->
32
-
Log.info (fun m -> m "%s's joke cost: $%.6f" name cost)
33
-
| None -> ());
34
-
Log.debug (fun m -> m "%s session: %s, duration: %dms"
35
-
name
36
-
(Claude.Message.Result.session_id msg)
37
-
(Claude.Message.Result.duration_ms msg))
38
-
| Claude.Message.System _ ->
39
-
(* System messages are already logged by the library *)
40
-
()
41
-
| Claude.Message.User _ ->
42
-
(* User messages are already logged by the library *)
43
-
()
44
-
) messages
10
+
List.iter
11
+
(fun msg ->
12
+
match msg with
13
+
| Claude.Message.Assistant msg ->
14
+
List.iter
15
+
(function
16
+
| Claude.Content_block.Text t ->
17
+
let text = Claude.Content_block.Text.text t in
18
+
Log.app (fun m -> m "%s: %s" name text)
19
+
| Claude.Content_block.Tool_use t ->
20
+
Log.debug (fun m ->
21
+
m "%s using tool: %s" name
22
+
(Claude.Content_block.Tool_use.name t))
23
+
| Claude.Content_block.Thinking t ->
24
+
Log.debug (fun m ->
25
+
m "%s thinking: %s" name
26
+
(Claude.Content_block.Thinking.thinking t))
27
+
| _ -> ())
28
+
(Claude.Message.Assistant.content msg);
29
+
Log.debug (fun m ->
30
+
m "%s using model: %s" name (Claude.Message.Assistant.model msg))
31
+
| Claude.Message.Result msg ->
32
+
(if Claude.Message.Result.is_error msg then
33
+
Log.err (fun m -> m "Error from %s!" name)
34
+
else
35
+
match Claude.Message.Result.total_cost_usd msg with
36
+
| Some cost ->
37
+
Log.info (fun m -> m "%s's joke cost: $%.6f" name cost)
38
+
| None -> ());
39
+
Log.debug (fun m ->
40
+
m "%s session: %s, duration: %dms" name
41
+
(Claude.Message.Result.session_id msg)
42
+
(Claude.Message.Result.duration_ms msg))
43
+
| Claude.Message.System _ ->
44
+
(* System messages are already logged by the library *)
45
+
()
46
+
| Claude.Message.User _ ->
47
+
(* User messages are already logged by the library *)
48
+
())
49
+
messages
45
50
46
51
let run_claude ~sw ~env name prompt =
47
52
Log.info (fun m -> m "🐪 Starting %s..." name);
48
-
let options = Claude.Options.create ~model:(Claude.Model.of_string "sonnet") ~allowed_tools:[] () in
49
-
50
-
let client = Claude.Client.create ~options ~sw
51
-
~process_mgr:env#process_mgr
52
-
() in
53
-
53
+
let options =
54
+
Claude.Options.create
55
+
~model:(Claude.Model.of_string "sonnet")
56
+
~allowed_tools:[] ()
57
+
in
58
+
59
+
let client =
60
+
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr ()
61
+
in
62
+
54
63
Claude.Client.query client prompt;
55
64
process_claude_response client name
56
65
57
66
let main ~env =
58
67
Switch.run @@ fun sw ->
59
-
60
68
Log.app (fun m -> m "🐪 Starting the Great Camel Joke Competition! 🐪");
61
69
Log.app (fun m -> m "================================================\n");
62
-
63
-
let prompts = [
64
-
"Claude 1", "Tell me a short, funny joke about camels! Make it original and clever.";
65
-
"Claude 2", "Give me your best camel joke - something witty and unexpected!";
66
-
"Claude 3", "Share a hilarious camel joke that will make everyone laugh!";
67
-
] in
68
-
70
+
71
+
let prompts =
72
+
[
73
+
( "Claude 1",
74
+
"Tell me a short, funny joke about camels! Make it original and clever."
75
+
);
76
+
( "Claude 2",
77
+
"Give me your best camel joke - something witty and unexpected!" );
78
+
("Claude 3", "Share a hilarious camel joke that will make everyone laugh!");
79
+
]
80
+
in
81
+
69
82
(* Run all three Claudes concurrently *)
70
-
Fiber.all (
71
-
List.map (fun (name, prompt) ->
72
-
fun () -> run_claude ~sw ~env name prompt
73
-
) prompts
74
-
);
75
-
83
+
Fiber.all
84
+
(List.map
85
+
(fun (name, prompt) -> fun () -> run_claude ~sw ~env name prompt)
86
+
prompts);
87
+
76
88
Log.app (fun m -> m "\n================================================");
77
89
Log.app (fun m -> m "🎉 The Camel Joke Competition is complete! 🎉")
78
90
···
98
110
99
111
let cmd env =
100
112
let doc = "Run the Great Camel Joke Competition using Claude" in
101
-
let man = [
102
-
`S Manpage.s_description;
103
-
`P "This program runs three concurrent Claude instances to generate camel jokes.";
104
-
`P "Use $(b,-v) or $(b,--verbosity=info) to see RPC message traffic.";
105
-
`P "Use $(b,-vv) or $(b,--verbosity=debug) to see all internal operations.";
106
-
`S Manpage.s_examples;
107
-
`P "Run with normal output:";
108
-
`Pre " $(mname)";
109
-
`P "Run with info-level logging (RPC traffic):";
110
-
`Pre " $(mname) -v";
111
-
`Pre " $(mname) --verbosity=info";
112
-
`P "Run with debug logging (all operations):";
113
-
`Pre " $(mname) -vv";
114
-
`Pre " $(mname) --verbosity=debug";
115
-
`P "Enable debug for specific modules:";
116
-
`Pre " LOGS='claude.transport=debug' $(mname)";
117
-
`Pre " LOGS='claude.message=info,camel_jokes=debug' $(mname)";
118
-
`S Manpage.s_bugs;
119
-
`P "Report bugs at https://github.com/your-repo/issues";
120
-
] in
113
+
let man =
114
+
[
115
+
`S Manpage.s_description;
116
+
`P
117
+
"This program runs three concurrent Claude instances to generate camel \
118
+
jokes.";
119
+
`P "Use $(b,-v) or $(b,--verbosity=info) to see RPC message traffic.";
120
+
`P
121
+
"Use $(b,-vv) or $(b,--verbosity=debug) to see all internal operations.";
122
+
`S Manpage.s_examples;
123
+
`P "Run with normal output:";
124
+
`Pre " $(mname)";
125
+
`P "Run with info-level logging (RPC traffic):";
126
+
`Pre " $(mname) -v";
127
+
`Pre " $(mname) --verbosity=info";
128
+
`P "Run with debug logging (all operations):";
129
+
`Pre " $(mname) -vv";
130
+
`Pre " $(mname) --verbosity=debug";
131
+
`P "Enable debug for specific modules:";
132
+
`Pre " LOGS='claude.transport=debug' $(mname)";
133
+
`Pre " LOGS='claude.message=info,camel_jokes=debug' $(mname)";
134
+
`S Manpage.s_bugs;
135
+
`P "Report bugs at https://github.com/your-repo/issues";
136
+
]
137
+
in
121
138
let info = Cmd.info "camel_jokes" ~version:"1.0" ~doc ~man in
122
139
Cmd.v info (main_term env)
123
140
124
-
let () =
125
-
Eio_main.run @@ fun env ->
126
-
exit (Cmd.eval (cmd env))
141
+
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
+67
-52
test/discovery_demo.ml
+67
-52
test/discovery_demo.ml
···
1
1
open Eio.Std
2
2
3
-
let src = Logs.Src.create "discovery_demo" ~doc:"Permission discovery demonstration"
3
+
let src =
4
+
Logs.Src.create "discovery_demo" ~doc:"Permission discovery demonstration"
5
+
4
6
module Log = (val Logs.src_log src : Logs.LOG)
5
7
6
8
let process_response client =
7
9
let messages = Claude.Client.receive_all client in
8
-
List.iter (fun msg ->
9
-
match msg with
10
-
| Claude.Message.Assistant msg ->
11
-
List.iter (function
12
-
| Claude.Content_block.Text t ->
13
-
let text = Claude.Content_block.Text.text t in
14
-
Log.app (fun m -> m "Claude: %s"
15
-
(if String.length text > 100 then
16
-
String.sub text 0 100 ^ "..."
17
-
else text))
18
-
| Claude.Content_block.Tool_use t ->
19
-
Log.info (fun m -> m "Tool use: %s"
20
-
(Claude.Content_block.Tool_use.name t))
21
-
| _ -> ()
22
-
) (Claude.Message.Assistant.content msg)
23
-
| Claude.Message.Result msg ->
24
-
if Claude.Message.Result.is_error msg then
25
-
Log.err (fun m -> m "Error occurred!")
26
-
else
27
-
(match Claude.Message.Result.total_cost_usd msg with
28
-
| Some cost ->
29
-
Log.info (fun m -> m "Cost: $%.6f" cost)
30
-
| None -> ())
31
-
| _ -> ()
32
-
) messages
10
+
List.iter
11
+
(fun msg ->
12
+
match msg with
13
+
| Claude.Message.Assistant msg ->
14
+
List.iter
15
+
(function
16
+
| Claude.Content_block.Text t ->
17
+
let text = Claude.Content_block.Text.text t in
18
+
Log.app (fun m ->
19
+
m "Claude: %s"
20
+
(if String.length text > 100 then
21
+
String.sub text 0 100 ^ "..."
22
+
else text))
23
+
| Claude.Content_block.Tool_use t ->
24
+
Log.info (fun m ->
25
+
m "Tool use: %s" (Claude.Content_block.Tool_use.name t))
26
+
| _ -> ())
27
+
(Claude.Message.Assistant.content msg)
28
+
| Claude.Message.Result msg -> (
29
+
if Claude.Message.Result.is_error msg then
30
+
Log.err (fun m -> m "Error occurred!")
31
+
else
32
+
match Claude.Message.Result.total_cost_usd msg with
33
+
| Some cost -> Log.info (fun m -> m "Cost: $%.6f" cost)
34
+
| None -> ())
35
+
| _ -> ())
36
+
messages
33
37
34
38
let run_discovery ~sw ~env =
35
39
Log.app (fun m -> m "🔍 Permission Discovery Demo");
36
40
Log.app (fun m -> m "=============================");
37
41
Log.app (fun m -> m "This will discover what permissions Claude needs.\n");
38
-
42
+
39
43
(* Create client with discovery mode *)
40
-
let options = Claude.Options.create ~model:(Claude.Model.of_string "sonnet") () in
41
-
let client = Claude.Client.discover_permissions
42
-
(Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr ()) in
43
-
44
+
let options =
45
+
Claude.Options.create ~model:(Claude.Model.of_string "sonnet") ()
46
+
in
47
+
let client =
48
+
Claude.Client.discover_permissions
49
+
(Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr ())
50
+
in
51
+
44
52
(* Send a prompt that will need permissions *)
45
53
Log.app (fun m -> m "Asking Claude to read a secret file...");
46
-
Claude.Client.query client
47
-
"Please read the file test/secret_data.txt and tell me what the secret code is.";
54
+
Claude.Client.query client
55
+
"Please read the file test/secret_data.txt and tell me what the secret \
56
+
code is.";
48
57
process_response client;
49
-
58
+
50
59
(* Check what permissions were requested *)
51
60
let permissions = Claude.Client.get_discovered_permissions client in
52
61
if permissions = [] then
53
-
Log.app (fun m -> m "\n📋 No permissions were requested (Claude may have used its knowledge).")
62
+
Log.app (fun m ->
63
+
m
64
+
"\n\
65
+
📋 No permissions were requested (Claude may have used its \
66
+
knowledge).")
54
67
else begin
55
68
Log.app (fun m -> m "\n📋 Permissions that were requested:");
56
-
List.iter (fun rule ->
57
-
Log.app (fun m -> m " - Tool: %s%s"
58
-
(Claude.Permissions.Rule.tool_name rule)
59
-
(match Claude.Permissions.Rule.rule_content rule with
60
-
| Some content -> Printf.sprintf " (rule: %s)" content
61
-
| None -> ""))
62
-
) permissions
69
+
List.iter
70
+
(fun rule ->
71
+
Log.app (fun m ->
72
+
m " - Tool: %s%s"
73
+
(Claude.Permissions.Rule.tool_name rule)
74
+
(match Claude.Permissions.Rule.rule_content rule with
75
+
| Some content -> Printf.sprintf " (rule: %s)" content
76
+
| None -> "")))
77
+
permissions
63
78
end
64
79
65
-
let main ~env =
66
-
Switch.run @@ fun sw ->
67
-
run_discovery ~sw ~env
80
+
let main ~env = Switch.run @@ fun sw -> run_discovery ~sw ~env
68
81
69
82
(* Command-line interface *)
70
83
open Cmdliner
···
84
97
85
98
let cmd env =
86
99
let doc = "Discover what permissions Claude needs" in
87
-
let man = [
88
-
`S Manpage.s_description;
89
-
`P "This program runs Claude in discovery mode to see what permissions it requests.";
90
-
] in
100
+
let man =
101
+
[
102
+
`S Manpage.s_description;
103
+
`P
104
+
"This program runs Claude in discovery mode to see what permissions it \
105
+
requests.";
106
+
]
107
+
in
91
108
let info = Cmd.info "discovery_demo" ~version:"1.0" ~doc ~man in
92
109
Cmd.v info (main_term env)
93
110
94
-
let () =
95
-
Eio_main.run @@ fun env ->
96
-
exit (Cmd.eval (cmd env))
111
+
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
+35
-6
test/dune
+35
-6
test/dune
···
13
13
(public_name permission_demo)
14
14
(name permission_demo)
15
15
(modules permission_demo)
16
-
(libraries test_json_utils claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
16
+
(libraries
17
+
test_json_utils
18
+
claude
19
+
eio_main
20
+
cmdliner
21
+
logs
22
+
logs.fmt
23
+
fmt.tty
24
+
fmt.cli
25
+
logs.cli))
17
26
18
27
(executable
19
28
(public_name discovery_demo)
···
37
46
(public_name simple_permission_test)
38
47
(name simple_permission_test)
39
48
(modules simple_permission_test)
40
-
(libraries test_json_utils claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
49
+
(libraries
50
+
test_json_utils
51
+
claude
52
+
eio_main
53
+
cmdliner
54
+
logs
55
+
logs.fmt
56
+
fmt.tty
57
+
fmt.cli
58
+
logs.cli))
41
59
42
60
(executable
43
61
(public_name hooks_example)
44
62
(name hooks_example)
45
63
(modules hooks_example)
46
-
(libraries test_json_utils claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
64
+
(libraries
65
+
test_json_utils
66
+
claude
67
+
eio_main
68
+
cmdliner
69
+
logs
70
+
logs.fmt
71
+
fmt.tty
72
+
fmt.cli
73
+
logs.cli))
47
74
48
75
(executable
49
76
(public_name dynamic_control_demo)
···
61
88
(public_name structured_output_demo)
62
89
(name structured_output_demo)
63
90
(modules structured_output_demo)
64
-
(flags (:standard -w -33))
91
+
(flags
92
+
(:standard -w -33))
65
93
(libraries test_json_utils claude eio_main logs logs.fmt fmt.tty))
66
94
67
95
(executable
68
96
(public_name structured_output_simple)
69
97
(name structured_output_simple)
70
98
(modules structured_output_simple)
71
-
(flags (:standard -w -33))
99
+
(flags
100
+
(:standard -w -33))
72
101
(libraries test_json_utils claude eio_main logs logs.fmt fmt.tty))
73
102
74
103
(executable
75
104
(public_name test_incoming)
76
105
(name test_incoming)
77
106
(modules test_incoming)
78
-
(libraries claude jsont.bytesrw))
107
+
(libraries claude jsont.bytesrw))
+42
-39
test/dynamic_control_demo.ml
+42
-39
test/dynamic_control_demo.ml
···
20
20
21
21
(* Consume initial messages *)
22
22
let messages = Client.receive_all client in
23
-
List.iter (function
24
-
| Message.Assistant msg ->
25
-
List.iter (function
26
-
| Content_block.Text t ->
27
-
traceln "Assistant: %s" (Content_block.Text.text t)
28
-
| _ -> ()
29
-
) (Message.Assistant.content msg)
30
-
| _ -> ()
31
-
) messages;
23
+
List.iter
24
+
(function
25
+
| Message.Assistant msg ->
26
+
List.iter
27
+
(function
28
+
| Content_block.Text t ->
29
+
traceln "Assistant: %s" (Content_block.Text.text t)
30
+
| _ -> ())
31
+
(Message.Assistant.content msg)
32
+
| _ -> ())
33
+
messages;
32
34
33
35
traceln "\n2. Getting server info...";
34
36
(try
35
-
let info = Client.get_server_info client in
36
-
traceln "Server version: %s" (Sdk_control.Server_info.version info);
37
-
traceln "Capabilities: [%s]"
38
-
(String.concat ", " (Sdk_control.Server_info.capabilities info));
39
-
traceln "Commands: [%s]"
40
-
(String.concat ", " (Sdk_control.Server_info.commands info));
41
-
traceln "Output styles: [%s]"
42
-
(String.concat ", " (Sdk_control.Server_info.output_styles info));
43
-
with
37
+
let info = Client.get_server_info client in
38
+
traceln "Server version: %s" (Sdk_control.Server_info.version info);
39
+
traceln "Capabilities: [%s]"
40
+
(String.concat ", " (Sdk_control.Server_info.capabilities info));
41
+
traceln "Commands: [%s]"
42
+
(String.concat ", " (Sdk_control.Server_info.commands info));
43
+
traceln "Output styles: [%s]"
44
+
(String.concat ", " (Sdk_control.Server_info.output_styles info))
45
+
with
44
46
| Failure msg -> traceln "Failed to get server info: %s" msg
45
47
| exn -> traceln "Error getting server info: %s" (Printexc.to_string exn));
46
48
47
49
traceln "\n3. Switching to a different model (if available)...";
48
50
(try
49
-
Client.set_model_string client "claude-sonnet-4";
50
-
traceln "Model switched successfully";
51
+
Client.set_model client (Model.of_string "claude-sonnet-4");
52
+
traceln "Model switched successfully";
51
53
52
-
(* Query with new model *)
53
-
Client.query client "Confirm your model again please.";
54
-
let messages = Client.receive_all client in
55
-
List.iter (function
56
-
| Message.Assistant msg ->
57
-
List.iter (function
58
-
| Content_block.Text t ->
59
-
traceln "Assistant (new model): %s" (Content_block.Text.text t)
60
-
| _ -> ()
61
-
) (Message.Assistant.content msg)
62
-
| _ -> ()
63
-
) messages;
64
-
with
54
+
(* Query with new model *)
55
+
Client.query client "Confirm your model again please.";
56
+
let messages = Client.receive_all client in
57
+
List.iter
58
+
(function
59
+
| Message.Assistant msg ->
60
+
List.iter
61
+
(function
62
+
| Content_block.Text t ->
63
+
traceln "Assistant (new model): %s"
64
+
(Content_block.Text.text t)
65
+
| _ -> ())
66
+
(Message.Assistant.content msg)
67
+
| _ -> ())
68
+
messages
69
+
with
65
70
| Failure msg -> traceln "Failed to switch model: %s" msg
66
71
| exn -> traceln "Error switching model: %s" (Printexc.to_string exn));
67
72
68
73
traceln "\n4. Changing permission mode...";
69
74
(try
70
-
Client.set_permission_mode client Permissions.Mode.Accept_edits;
71
-
traceln "Permission mode changed to Accept_edits";
72
-
with
75
+
Client.set_permission_mode client Permissions.Mode.Accept_edits;
76
+
traceln "Permission mode changed to Accept_edits"
77
+
with
73
78
| Failure msg -> traceln "Failed to change permission mode: %s" msg
74
79
| exn -> traceln "Error changing permission mode: %s" (Printexc.to_string exn));
75
80
···
78
83
79
84
let () =
80
85
Eio_main.run @@ fun env ->
81
-
try
82
-
run env
83
-
with
86
+
try run env with
84
87
| Transport.CLI_not_found msg ->
85
88
traceln "Error: %s" msg;
86
89
traceln "Make sure the 'claude' CLI is installed and authenticated.";
+62
-60
test/hooks_example.ml
+62
-60
test/hooks_example.ml
···
1
1
open Eio.Std
2
2
3
3
let src = Logs.Src.create "hooks_example" ~doc:"Hooks example"
4
+
4
5
module Log = (val Logs.src_log src : Logs.LOG)
5
6
6
7
(* Example 1: Block dangerous bash commands *)
···
14
15
| Some command ->
15
16
if String.length command >= 6 && String.sub command 0 6 = "rm -rf" then begin
16
17
Log.app (fun m -> m "🚫 Blocked dangerous command: %s" command);
17
-
let output = Claude.Hooks.PreToolUse.deny
18
-
~reason:"Command contains dangerous 'rm -rf' pattern" () in
18
+
let output =
19
+
Claude.Hooks.PreToolUse.deny
20
+
~reason:"Command contains dangerous 'rm -rf' pattern" ()
21
+
in
19
22
Claude.Hooks.continue
20
23
~system_message:"Blocked dangerous rm -rf command"
21
-
~hook_specific_output:(Claude.Hooks.PreToolUse.output_to_json output)
24
+
~hook_specific_output:
25
+
(Claude.Hooks.PreToolUse.output_to_json output)
22
26
()
23
-
end else
24
-
Claude.Hooks.continue ()
25
-
| _ ->
26
-
Claude.Hooks.continue ()
27
-
else
28
-
Claude.Hooks.continue ()
27
+
end
28
+
else Claude.Hooks.continue ()
29
+
| _ -> Claude.Hooks.continue ()
30
+
else Claude.Hooks.continue ()
29
31
30
32
(* Example 2: Log all tool usage *)
31
33
let log_tool_usage ~input ~tool_use_id ~context:_ =
···
42
44
(* Configure hooks *)
43
45
let hooks =
44
46
Claude.Hooks.empty
45
-
|> Claude.Hooks.add Claude.Hooks.Pre_tool_use [
46
-
(* Log all tool usage *)
47
-
Claude.Hooks.matcher [log_tool_usage];
48
-
(* Block dangerous bash commands *)
49
-
Claude.Hooks.matcher ~pattern:"Bash" [block_dangerous_bash];
50
-
]
47
+
|> Claude.Hooks.add Claude.Hooks.Pre_tool_use
48
+
[
49
+
(* Log all tool usage *)
50
+
Claude.Hooks.matcher [ log_tool_usage ];
51
+
(* Block dangerous bash commands *)
52
+
Claude.Hooks.matcher ~pattern:"Bash" [ block_dangerous_bash ];
53
+
]
51
54
in
52
55
53
-
let options = Claude.Options.create
54
-
~model:(Claude.Model.of_string "sonnet")
55
-
~hooks
56
-
() in
56
+
let options =
57
+
Claude.Options.create ~model:(Claude.Model.of_string "sonnet") ~hooks ()
58
+
in
57
59
58
-
let client = Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr () in
60
+
let client =
61
+
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr ()
62
+
in
59
63
60
64
(* Test 1: Safe command (should work) *)
61
65
Log.app (fun m -> m "Test 1: Safe bash command");
62
66
Claude.Client.query client "Run the bash command: echo 'Hello from hooks!'";
63
67
64
68
let messages = Claude.Client.receive_all client in
65
-
List.iter (fun msg ->
66
-
match msg with
67
-
| Claude.Message.Assistant msg ->
68
-
List.iter (function
69
-
| Claude.Content_block.Text t ->
70
-
let text = Claude.Content_block.Text.text t in
71
-
if String.length text > 0 then
72
-
Log.app (fun m -> m "Claude: %s" text)
73
-
| _ -> ()
74
-
) (Claude.Message.Assistant.content msg)
75
-
| Claude.Message.Result msg ->
76
-
if Claude.Message.Result.is_error msg then
77
-
Log.err (fun m -> m "❌ Error!")
78
-
else
79
-
Log.app (fun m -> m "✅ Test 1 complete\n")
80
-
| _ -> ()
81
-
) messages;
69
+
List.iter
70
+
(fun msg ->
71
+
match msg with
72
+
| Claude.Message.Assistant msg ->
73
+
List.iter
74
+
(function
75
+
| Claude.Content_block.Text t ->
76
+
let text = Claude.Content_block.Text.text t in
77
+
if String.length text > 0 then
78
+
Log.app (fun m -> m "Claude: %s" text)
79
+
| _ -> ())
80
+
(Claude.Message.Assistant.content msg)
81
+
| Claude.Message.Result msg ->
82
+
if Claude.Message.Result.is_error msg then
83
+
Log.err (fun m -> m "❌ Error!")
84
+
else Log.app (fun m -> m "✅ Test 1 complete\n")
85
+
| _ -> ())
86
+
messages;
82
87
83
88
(* Test 2: Dangerous command (should be blocked) *)
84
89
Log.app (fun m -> m "Test 2: Dangerous bash command (should be blocked)");
85
90
Claude.Client.query client "Run the bash command: rm -rf /tmp/test";
86
91
87
92
let messages = Claude.Client.receive_all client in
88
-
List.iter (fun msg ->
89
-
match msg with
90
-
| Claude.Message.Assistant msg ->
91
-
List.iter (function
92
-
| Claude.Content_block.Text t ->
93
-
let text = Claude.Content_block.Text.text t in
94
-
if String.length text > 0 then
95
-
Log.app (fun m -> m "Claude: %s" text)
96
-
| _ -> ()
97
-
) (Claude.Message.Assistant.content msg)
98
-
| Claude.Message.Result msg ->
99
-
if Claude.Message.Result.is_error msg then
100
-
Log.err (fun m -> m "❌ Error!")
101
-
else
102
-
Log.app (fun m -> m "✅ Test 2 complete")
103
-
| _ -> ()
104
-
) messages;
93
+
List.iter
94
+
(fun msg ->
95
+
match msg with
96
+
| Claude.Message.Assistant msg ->
97
+
List.iter
98
+
(function
99
+
| Claude.Content_block.Text t ->
100
+
let text = Claude.Content_block.Text.text t in
101
+
if String.length text > 0 then
102
+
Log.app (fun m -> m "Claude: %s" text)
103
+
| _ -> ())
104
+
(Claude.Message.Assistant.content msg)
105
+
| Claude.Message.Result msg ->
106
+
if Claude.Message.Result.is_error msg then
107
+
Log.err (fun m -> m "❌ Error!")
108
+
else Log.app (fun m -> m "✅ Test 2 complete")
109
+
| _ -> ())
110
+
messages;
105
111
106
112
Log.app (fun m -> m "\n====================");
107
113
Log.app (fun m -> m "✨ Example complete!")
108
114
109
-
let main ~env =
110
-
Switch.run @@ fun sw ->
111
-
run_example ~sw ~env
115
+
let main ~env = Switch.run @@ fun sw -> run_example ~sw ~env
112
116
113
117
(* Command-line interface *)
114
118
open Cmdliner
···
135
139
let info = Cmd.info "hooks_example" ~version:"1.0" ~doc in
136
140
Cmd.v info (main_term env)
137
141
138
-
let () =
139
-
Eio_main.run @@ fun env ->
140
-
exit (Cmd.eval (cmd env))
142
+
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
+128
-115
test/permission_demo.ml
+128
-115
test/permission_demo.ml
···
1
1
open Eio.Std
2
2
3
-
let src = Logs.Src.create "permission_demo" ~doc:"Permission callback demonstration"
3
+
let src =
4
+
Logs.Src.create "permission_demo" ~doc:"Permission callback demonstration"
5
+
4
6
module Log = (val Logs.src_log src : Logs.LOG)
5
7
6
8
(* Mutable state to track what permissions have been granted *)
7
9
module Granted = struct
8
-
module StringSet = Set.Make(String)
10
+
module StringSet = Set.Make (String)
11
+
9
12
let tools = ref StringSet.empty
10
-
13
+
11
14
let grant tool_name =
12
15
tools := StringSet.add tool_name !tools;
13
16
Log.app (fun m -> m "✅ Permission granted for: %s" tool_name)
14
-
17
+
15
18
let deny tool_name =
16
19
Log.app (fun m -> m "❌ Permission denied for: %s" tool_name)
17
-
18
-
let is_granted tool_name =
19
-
StringSet.mem tool_name !tools
20
-
20
+
21
+
let is_granted tool_name = StringSet.mem tool_name !tools
22
+
21
23
let list () =
22
24
if StringSet.is_empty !tools then
23
25
Log.app (fun m -> m "No permissions granted yet")
24
26
else
25
-
Log.app (fun m -> m "Currently granted permissions: %s"
26
-
(StringSet.elements !tools |> String.concat ", "))
27
+
Log.app (fun m ->
28
+
m "Currently granted permissions: %s"
29
+
(StringSet.elements !tools |> String.concat ", "))
27
30
end
28
31
29
32
(* Interactive permission callback *)
···
31
34
Log.info (fun m -> m "🔔 Permission callback invoked for tool: %s" tool_name);
32
35
Log.app (fun m -> m "\n🔐 PERMISSION REQUEST 🔐");
33
36
Log.app (fun m -> m "Tool: %s" tool_name);
34
-
37
+
35
38
(* Log the full input for debugging *)
36
39
Log.info (fun m -> m "Full input JSON: %s" (Test_json_utils.to_string input));
37
-
40
+
38
41
(* Show input details *)
39
42
(* Try to extract key information from the input *)
40
43
(try
41
-
match tool_name with
42
-
| "Read" ->
43
-
(match Test_json_utils.get_string input "file_path" with
44
-
| Some file_path -> Log.app (fun m -> m "File: %s" file_path)
45
-
| None -> ())
46
-
| "Bash" ->
47
-
(match Test_json_utils.get_string input "command" with
48
-
| Some command -> Log.app (fun m -> m "Command: %s" command)
49
-
| None -> ())
50
-
| "Write" | "Edit" ->
51
-
(match Test_json_utils.get_string input "file_path" with
52
-
| Some file_path -> Log.app (fun m -> m "File: %s" file_path)
53
-
| None -> ())
54
-
| "Glob" ->
55
-
(match Test_json_utils.get_string input "pattern" with
56
-
| Some pattern ->
57
-
Log.app (fun m -> m "Pattern: %s" pattern);
58
-
(match Test_json_utils.get_string input "path" with
59
-
| Some path -> Log.app (fun m -> m "Path: %s" path)
60
-
| None -> Log.app (fun m -> m "Path: (current directory)"))
61
-
| None -> ())
62
-
| "Grep" ->
63
-
(match Test_json_utils.get_string input "pattern" with
64
-
| Some pattern ->
65
-
Log.app (fun m -> m "Pattern: %s" pattern);
66
-
(match Test_json_utils.get_string input "path" with
67
-
| Some path -> Log.app (fun m -> m "Path: %s" path)
68
-
| None -> Log.app (fun m -> m "Path: (current directory)"))
69
-
| None -> ())
70
-
| _ ->
71
-
Log.app (fun m -> m "Input: %s" (Test_json_utils.to_string input))
72
-
with exn ->
73
-
Log.info (fun m -> m "Failed to parse input details: %s" (Printexc.to_string exn)));
74
-
44
+
match tool_name with
45
+
| "Read" -> (
46
+
match Test_json_utils.get_string input "file_path" with
47
+
| Some file_path -> Log.app (fun m -> m "File: %s" file_path)
48
+
| None -> ())
49
+
| "Bash" -> (
50
+
match Test_json_utils.get_string input "command" with
51
+
| Some command -> Log.app (fun m -> m "Command: %s" command)
52
+
| None -> ())
53
+
| "Write" | "Edit" -> (
54
+
match Test_json_utils.get_string input "file_path" with
55
+
| Some file_path -> Log.app (fun m -> m "File: %s" file_path)
56
+
| None -> ())
57
+
| "Glob" -> (
58
+
match Test_json_utils.get_string input "pattern" with
59
+
| Some pattern -> (
60
+
Log.app (fun m -> m "Pattern: %s" pattern);
61
+
match Test_json_utils.get_string input "path" with
62
+
| Some path -> Log.app (fun m -> m "Path: %s" path)
63
+
| None -> Log.app (fun m -> m "Path: (current directory)"))
64
+
| None -> ())
65
+
| "Grep" -> (
66
+
match Test_json_utils.get_string input "pattern" with
67
+
| Some pattern -> (
68
+
Log.app (fun m -> m "Pattern: %s" pattern);
69
+
match Test_json_utils.get_string input "path" with
70
+
| Some path -> Log.app (fun m -> m "Path: %s" path)
71
+
| None -> Log.app (fun m -> m "Path: (current directory)"))
72
+
| None -> ())
73
+
| _ -> Log.app (fun m -> m "Input: %s" (Test_json_utils.to_string input))
74
+
with exn ->
75
+
Log.info (fun m ->
76
+
m "Failed to parse input details: %s" (Printexc.to_string exn)));
77
+
75
78
(* Check if already granted *)
76
79
if Granted.is_granted tool_name then begin
77
80
Log.app (fun m -> m "→ Auto-approved (previously granted)");
78
81
Log.info (fun m -> m "Returning allow result for %s" tool_name);
79
82
Claude.Permissions.Result.allow ()
80
-
end else begin
83
+
end
84
+
else begin
81
85
(* Ask user - read from /dev/tty since stdin is connected to Claude process *)
82
86
Printf.printf "Allow? [y/N/always]: %!";
83
87
let tty = open_in "/dev/tty" in
···
90
94
Claude.Permissions.Result.allow ()
91
95
| "a" | "always" ->
92
96
Granted.grant tool_name;
93
-
Log.info (fun m -> m "User granted permanent permission for %s" tool_name);
97
+
Log.info (fun m ->
98
+
m "User granted permanent permission for %s" tool_name);
94
99
Claude.Permissions.Result.allow ()
95
100
| _ ->
96
101
Granted.deny tool_name;
97
102
Log.info (fun m -> m "User denied permission for %s" tool_name);
98
-
Claude.Permissions.Result.deny ~message:(Printf.sprintf "User denied access to %s" tool_name) ~interrupt:false ()
103
+
Claude.Permissions.Result.deny
104
+
~message:(Printf.sprintf "User denied access to %s" tool_name)
105
+
~interrupt:false ()
99
106
end
100
107
101
108
let process_response client =
102
109
let messages = Claude.Client.receive_all client in
103
-
List.iter (fun msg ->
104
-
match msg with
105
-
| Claude.Message.Assistant msg ->
106
-
List.iter (function
107
-
| Claude.Content_block.Text t ->
108
-
let text = Claude.Content_block.Text.text t in
109
-
Log.app (fun m -> m "\n📝 Claude says:\n%s" text)
110
-
| Claude.Content_block.Tool_use t ->
111
-
Log.info (fun m -> m "🔧 Tool use: %s (id: %s)"
112
-
(Claude.Content_block.Tool_use.name t)
113
-
(Claude.Content_block.Tool_use.id t))
114
-
| _ -> ()
115
-
) (Claude.Message.Assistant.content msg)
116
-
| Claude.Message.Result msg ->
117
-
if Claude.Message.Result.is_error msg then
118
-
Log.err (fun m -> m "❌ Error occurred!")
119
-
else
120
-
(match Claude.Message.Result.total_cost_usd msg with
121
-
| Some cost ->
122
-
Log.info (fun m -> m "💰 Cost: $%.6f" cost)
123
-
| None -> ());
124
-
Log.info (fun m -> m "⏱️ Duration: %dms"
125
-
(Claude.Message.Result.duration_ms msg))
126
-
| _ -> ()
127
-
) messages
110
+
List.iter
111
+
(fun msg ->
112
+
match msg with
113
+
| Claude.Message.Assistant msg ->
114
+
List.iter
115
+
(function
116
+
| Claude.Content_block.Text t ->
117
+
let text = Claude.Content_block.Text.text t in
118
+
Log.app (fun m -> m "\n📝 Claude says:\n%s" text)
119
+
| Claude.Content_block.Tool_use t ->
120
+
Log.info (fun m ->
121
+
m "🔧 Tool use: %s (id: %s)"
122
+
(Claude.Content_block.Tool_use.name t)
123
+
(Claude.Content_block.Tool_use.id t))
124
+
| _ -> ())
125
+
(Claude.Message.Assistant.content msg)
126
+
| Claude.Message.Result msg ->
127
+
(if Claude.Message.Result.is_error msg then
128
+
Log.err (fun m -> m "❌ Error occurred!")
129
+
else
130
+
match Claude.Message.Result.total_cost_usd msg with
131
+
| Some cost -> Log.info (fun m -> m "💰 Cost: $%.6f" cost)
132
+
| None -> ());
133
+
Log.info (fun m ->
134
+
m "⏱️ Duration: %dms" (Claude.Message.Result.duration_ms msg))
135
+
| _ -> ())
136
+
messages
128
137
129
138
let run_demo ~sw ~env =
130
139
Log.app (fun m -> m "🚀 Starting Permission Demo");
131
140
Log.app (fun m -> m "==================================");
132
141
Log.app (fun m -> m "This demo starts with NO permissions.");
133
142
Log.app (fun m -> m "Claude will request permissions as needed.\n");
134
-
143
+
135
144
(* Create options with custom permission callback *)
136
145
(* DON'T specify allowed_tools - let the permission callback handle everything.
137
146
The Default permission mode with a callback should send requests for all tools. *)
138
-
let options = Claude.Options.create
139
-
~model:(Claude.Model.of_string "sonnet")
140
-
~permission_mode:Claude.Permissions.Mode.Default
141
-
~permission_callback:interactive_permission_callback
142
-
() in
143
-
144
-
let client = Claude.Client.create ~options ~sw
145
-
~process_mgr:env#process_mgr
146
-
() in
147
-
147
+
let options =
148
+
Claude.Options.create
149
+
~model:(Claude.Model.of_string "sonnet")
150
+
~permission_mode:Claude.Permissions.Mode.Default
151
+
~permission_callback:interactive_permission_callback ()
152
+
in
153
+
154
+
let client =
155
+
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr ()
156
+
in
157
+
148
158
(* First prompt - Claude will need to request Read permission for ../lib *)
149
159
Log.app (fun m -> m "\n📤 Sending first prompt (reading from ../lib)...");
150
-
Claude.Client.query client
151
-
"Please read and analyze the source files in the ../lib directory. Focus on the main OCaml modules and their purpose. What is the overall architecture of this Claude library?";
160
+
Claude.Client.query client
161
+
"Please read and analyze the source files in the ../lib directory. Focus \
162
+
on the main OCaml modules and their purpose. What is the overall \
163
+
architecture of this Claude library?";
152
164
process_response client;
153
-
165
+
154
166
(* Show current permissions *)
155
167
Log.app (fun m -> m "\n📋 Current permission status:");
156
168
Granted.list ();
157
-
169
+
158
170
(* Second prompt - will need Write permission *)
159
171
Log.app (fun m -> m "\n📤 Sending second prompt (writing TEST.md)...");
160
-
Claude.Client.query client
161
-
"Now write a summary of what you learned about the Claude library architecture to a file called TEST.md in the current directory. Include the main modules, their purposes, and how they work together.";
172
+
Claude.Client.query client
173
+
"Now write a summary of what you learned about the Claude library \
174
+
architecture to a file called TEST.md in the current directory. Include \
175
+
the main modules, their purposes, and how they work together.";
162
176
process_response client;
163
-
177
+
164
178
(* Show final permissions *)
165
179
Log.app (fun m -> m "\n📋 Final permission status:");
166
180
Granted.list ();
167
-
181
+
168
182
Log.app (fun m -> m "\n==================================");
169
183
Log.app (fun m -> m "✨ Demo complete!")
170
184
171
-
let main ~env =
172
-
Switch.run @@ fun sw ->
173
-
run_demo ~sw ~env
185
+
let main ~env = Switch.run @@ fun sw -> run_demo ~sw ~env
174
186
175
187
(* Command-line interface *)
176
188
open Cmdliner
···
196
208
197
209
let cmd env =
198
210
let doc = "Demonstrate Claude's dynamic permission system" in
199
-
let man = [
200
-
`S Manpage.s_description;
201
-
`P "This program demonstrates how to use permission callbacks with Claude.";
202
-
`P "It starts with no permissions and asks for them interactively.";
203
-
`P "You can grant permissions for:";
204
-
`P "- Individual requests (y/yes)";
205
-
`P "- All future requests of that type (a/always)";
206
-
`P "- Or deny the request (n/no or just press Enter)";
207
-
`S Manpage.s_examples;
208
-
`P "Run the demo:";
209
-
`Pre " $(mname)";
210
-
`P "Run with verbose output to see message flow:";
211
-
`Pre " $(mname) -v";
212
-
`S Manpage.s_bugs;
213
-
`P "Report bugs at https://github.com/your-repo/issues";
214
-
] in
211
+
let man =
212
+
[
213
+
`S Manpage.s_description;
214
+
`P
215
+
"This program demonstrates how to use permission callbacks with Claude.";
216
+
`P "It starts with no permissions and asks for them interactively.";
217
+
`P "You can grant permissions for:";
218
+
`P "- Individual requests (y/yes)";
219
+
`P "- All future requests of that type (a/always)";
220
+
`P "- Or deny the request (n/no or just press Enter)";
221
+
`S Manpage.s_examples;
222
+
`P "Run the demo:";
223
+
`Pre " $(mname)";
224
+
`P "Run with verbose output to see message flow:";
225
+
`Pre " $(mname) -v";
226
+
`S Manpage.s_bugs;
227
+
`P "Report bugs at https://github.com/your-repo/issues";
228
+
]
229
+
in
215
230
let info = Cmd.info "permission_demo" ~version:"1.0" ~doc ~man in
216
231
Cmd.v info (main_term env)
217
232
218
-
let () =
219
-
Eio_main.run @@ fun env ->
220
-
exit (Cmd.eval (cmd env))
233
+
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
+67
-60
test/simple_permission_test.ml
+67
-60
test/simple_permission_test.ml
···
1
1
open Eio.Std
2
2
3
3
let src = Logs.Src.create "simple_permission_test" ~doc:"Simple permission test"
4
+
4
5
module Log = (val Logs.src_log src : Logs.LOG)
5
6
6
7
(* Auto-allow callback that logs what it sees *)
···
16
17
Log.app (fun m -> m "====================================================");
17
18
18
19
(* Create options with permission callback *)
19
-
let options = Claude.Options.create
20
-
~model:(Claude.Model.of_string "sonnet")
21
-
~permission_callback:auto_allow_callback
22
-
() in
20
+
let options =
21
+
Claude.Options.create
22
+
~model:(Claude.Model.of_string "sonnet")
23
+
~permission_callback:auto_allow_callback ()
24
+
in
23
25
24
26
Log.app (fun m -> m "Creating client with permission callback...");
25
-
let client = Claude.Client.create ~options ~sw
26
-
~process_mgr:env#process_mgr
27
-
() in
27
+
let client =
28
+
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr ()
29
+
in
28
30
29
31
(* Query that should trigger Write tool *)
30
32
Log.app (fun m -> m "\n📤 Asking Claude to write a file...");
···
38
40
let tool_count = ref 0 in
39
41
let write_used = ref false in
40
42
41
-
List.iter (fun msg ->
42
-
match msg with
43
-
| Claude.Message.Assistant msg ->
44
-
List.iter (function
45
-
| Claude.Content_block.Text t ->
46
-
let text = Claude.Content_block.Text.text t in
47
-
if String.length text > 0 then
48
-
Log.app (fun m -> m "\n💬 Claude: %s" text)
49
-
| Claude.Content_block.Tool_use t ->
50
-
incr tool_count;
51
-
let tool_name = Claude.Content_block.Tool_use.name t in
52
-
if tool_name = "Write" then write_used := true;
53
-
Log.app (fun m -> m "🔧 Tool use #%d: %s" !tool_count tool_name)
54
-
| _ -> ()
55
-
) (Claude.Message.Assistant.content msg)
56
-
| Claude.Message.User msg ->
57
-
(* Check for tool results which might have errors *)
58
-
(match Claude.Message.User.content msg with
59
-
| Claude.Message.User.Blocks blocks ->
60
-
List.iter (function
61
-
| Claude.Content_block.Tool_result r ->
62
-
let tool_use_id = Claude.Content_block.Tool_result.tool_use_id r in
63
-
let is_error = Claude.Content_block.Tool_result.is_error r |> Option.value ~default:false in
64
-
if is_error then begin
65
-
Log.app (fun m -> m "\n⚠️ Tool result error for %s:" tool_use_id);
66
-
(match Claude.Content_block.Tool_result.content r with
67
-
| Some s -> Log.app (fun m -> m " %s" s)
68
-
| None -> ())
69
-
end
70
-
| _ -> ()
71
-
) blocks
72
-
| _ -> ())
73
-
| Claude.Message.Result msg ->
74
-
if Claude.Message.Result.is_error msg then
75
-
Log.err (fun m -> m "\n❌ Error occurred!")
76
-
else
77
-
Log.app (fun m -> m "\n✅ Success!");
78
-
(match Claude.Message.Result.total_cost_usd msg with
79
-
| Some cost -> Log.app (fun m -> m "💰 Cost: $%.6f" cost)
80
-
| None -> ());
81
-
Log.app (fun m -> m "⏱️ Duration: %dms"
82
-
(Claude.Message.Result.duration_ms msg))
83
-
| _ -> ()
84
-
) messages;
43
+
List.iter
44
+
(fun msg ->
45
+
match msg with
46
+
| Claude.Message.Assistant msg ->
47
+
List.iter
48
+
(function
49
+
| Claude.Content_block.Text t ->
50
+
let text = Claude.Content_block.Text.text t in
51
+
if String.length text > 0 then
52
+
Log.app (fun m -> m "\n💬 Claude: %s" text)
53
+
| Claude.Content_block.Tool_use t ->
54
+
incr tool_count;
55
+
let tool_name = Claude.Content_block.Tool_use.name t in
56
+
if tool_name = "Write" then write_used := true;
57
+
Log.app (fun m ->
58
+
m "🔧 Tool use #%d: %s" !tool_count tool_name)
59
+
| _ -> ())
60
+
(Claude.Message.Assistant.content msg)
61
+
| Claude.Message.User msg -> (
62
+
(* Check for tool results which might have errors *)
63
+
match Claude.Message.User.content msg with
64
+
| Claude.Message.User.Blocks blocks ->
65
+
List.iter
66
+
(function
67
+
| Claude.Content_block.Tool_result r ->
68
+
let tool_use_id =
69
+
Claude.Content_block.Tool_result.tool_use_id r
70
+
in
71
+
let is_error =
72
+
Claude.Content_block.Tool_result.is_error r
73
+
|> Option.value ~default:false
74
+
in
75
+
if is_error then begin
76
+
Log.app (fun m ->
77
+
m "\n⚠️ Tool result error for %s:" tool_use_id);
78
+
match Claude.Content_block.Tool_result.content r with
79
+
| Some s -> Log.app (fun m -> m " %s" s)
80
+
| None -> ()
81
+
end
82
+
| _ -> ())
83
+
blocks
84
+
| _ -> ())
85
+
| Claude.Message.Result msg ->
86
+
if Claude.Message.Result.is_error msg then
87
+
Log.err (fun m -> m "\n❌ Error occurred!")
88
+
else Log.app (fun m -> m "\n✅ Success!");
89
+
(match Claude.Message.Result.total_cost_usd msg with
90
+
| Some cost -> Log.app (fun m -> m "💰 Cost: $%.6f" cost)
91
+
| None -> ());
92
+
Log.app (fun m ->
93
+
m "⏱️ Duration: %dms" (Claude.Message.Result.duration_ms msg))
94
+
| _ -> ())
95
+
messages;
85
96
86
97
Log.app (fun m -> m "\n====================================================");
87
98
Log.app (fun m -> m "📊 Test Results:");
···
89
100
Log.app (fun m -> m " Write tool used: %b" !write_used);
90
101
91
102
if !write_used then
92
-
Log.app (fun m -> m " ✅ Permission callback successfully intercepted Write tool!")
93
-
else
94
-
Log.app (fun m -> m " ⚠️ Write tool was not used (unexpected)");
103
+
Log.app (fun m ->
104
+
m " ✅ Permission callback successfully intercepted Write tool!")
105
+
else Log.app (fun m -> m " ⚠️ Write tool was not used (unexpected)");
95
106
96
107
Log.app (fun m -> m "====================================================");
97
108
Log.app (fun m -> m "✨ Test complete!")
98
109
99
-
let main ~env =
100
-
Switch.run @@ fun sw ->
101
-
run_test ~sw ~env
110
+
let main ~env = Switch.run @@ fun sw -> run_test ~sw ~env
102
111
103
112
(* Command-line interface *)
104
113
open Cmdliner
···
126
135
let info = Cmd.info "simple_permission_test" ~version:"1.0" ~doc in
127
136
Cmd.v info (main_term env)
128
137
129
-
let () =
130
-
Eio_main.run @@ fun env ->
131
-
exit (Cmd.eval (cmd env))
138
+
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
+96
-74
test/simulated_permissions.ml
+96
-74
test/simulated_permissions.ml
···
1
-
let src = Logs.Src.create "simulated_permissions" ~doc:"Simulated permission demonstration"
1
+
let src =
2
+
Logs.Src.create "simulated_permissions"
3
+
~doc:"Simulated permission demonstration"
4
+
2
5
module Log = (val Logs.src_log src : Logs.LOG)
3
6
4
7
(* Track granted permissions *)
5
8
module PermissionState = struct
6
-
module StringSet = Set.Make(String)
9
+
module StringSet = Set.Make (String)
10
+
7
11
let granted = ref StringSet.empty
8
12
let denied = ref StringSet.empty
9
-
13
+
10
14
let grant tool =
11
15
granted := StringSet.add tool !granted;
12
16
denied := StringSet.remove tool !denied
13
-
17
+
14
18
let deny tool =
15
19
denied := StringSet.add tool !denied;
16
20
granted := StringSet.remove tool !granted
17
-
21
+
18
22
let is_granted tool = StringSet.mem tool !granted
19
23
let is_denied tool = StringSet.mem tool !denied
20
-
24
+
21
25
let _reset () =
22
26
granted := StringSet.empty;
23
27
denied := StringSet.empty
24
-
28
+
25
29
let show () =
26
30
Log.app (fun m -> m "\n📊 Permission Status:");
27
31
if StringSet.is_empty !granted && StringSet.is_empty !denied then
28
32
Log.app (fun m -> m " No permissions configured")
29
33
else begin
30
34
if not (StringSet.is_empty !granted) then
31
-
Log.app (fun m -> m " ✅ Granted: %s"
32
-
(StringSet.elements !granted |> String.concat ", "));
33
-
if not (StringSet.is_empty !denied) then
34
-
Log.app (fun m -> m " ❌ Denied: %s"
35
-
(StringSet.elements !denied |> String.concat ", "))
35
+
Log.app (fun m ->
36
+
m " ✅ Granted: %s"
37
+
(StringSet.elements !granted |> String.concat ", "));
38
+
if not (StringSet.is_empty !denied) then
39
+
Log.app (fun m ->
40
+
m " ❌ Denied: %s" (StringSet.elements !denied |> String.concat ", "))
36
41
end
37
42
end
38
43
39
44
(* Example permission callback *)
40
45
let example_permission_callback ~tool_name ~input:_ ~context:_ =
41
46
Log.app (fun m -> m "\n🔐 Permission Request for: %s" tool_name);
42
-
47
+
43
48
(* Check current state *)
44
49
if PermissionState.is_granted tool_name then begin
45
50
Log.app (fun m -> m " → Auto-approved (previously granted)");
46
51
Claude.Permissions.Result.allow ()
47
-
end else if PermissionState.is_denied tool_name then begin
52
+
end
53
+
else if PermissionState.is_denied tool_name then begin
48
54
Log.app (fun m -> m " → Auto-denied (previously denied)");
49
55
Claude.Permissions.Result.deny
50
56
~message:(Printf.sprintf "Tool %s is blocked by policy" tool_name)
51
57
~interrupt:false ()
52
-
end else begin
58
+
end
59
+
else begin
53
60
(* Ask user *)
54
61
Printf.printf " Allow %s? [y/n/always/never]: %!" tool_name;
55
62
match read_line () |> String.lowercase_ascii with
···
73
80
~interrupt:false ()
74
81
| _ ->
75
82
Log.app (fun m -> m " → Denied (invalid response)");
76
-
Claude.Permissions.Result.deny
77
-
~message:"Invalid permission response"
83
+
Claude.Permissions.Result.deny ~message:"Invalid permission response"
78
84
~interrupt:false ()
79
85
end
80
86
···
82
88
let demo_permissions () =
83
89
Log.app (fun m -> m "🎭 Permission System Demonstration");
84
90
Log.app (fun m -> m "==================================\n");
85
-
91
+
86
92
(* Simulate permission requests *)
87
-
let tools = ["Read"; "Write"; "Bash"; "Edit"] in
93
+
let tools = [ "Read"; "Write"; "Bash"; "Edit" ] in
88
94
let context = Claude.Permissions.Context.create () in
89
-
95
+
90
96
Log.app (fun m -> m "This demo simulates permission requests.");
91
97
Log.app (fun m -> m "You can respond with: y/n/always/never\n");
92
-
98
+
93
99
(* Test each tool *)
94
-
List.iter (fun tool ->
95
-
let input =
96
-
let open Jsont in
97
-
Object ([
98
-
(("file_path", Meta.none), String ("/example/path.txt", Meta.none))
99
-
], Meta.none)
100
-
in
101
-
let result = example_permission_callback
102
-
~tool_name:tool ~input ~context in
103
-
104
-
(* Show result *)
105
-
(match result with
106
-
| Claude.Permissions.Result.Allow _ ->
107
-
Log.info (fun m -> m "Result: Permission granted for %s" tool)
108
-
| Claude.Permissions.Result.Deny { message; _ } ->
109
-
Log.info (fun m -> m "Result: Permission denied for %s - %s" tool message))
110
-
) tools;
111
-
100
+
List.iter
101
+
(fun tool ->
102
+
let input =
103
+
let open Jsont in
104
+
Object
105
+
( [
106
+
(("file_path", Meta.none), String ("/example/path.txt", Meta.none));
107
+
],
108
+
Meta.none )
109
+
in
110
+
let result =
111
+
example_permission_callback ~tool_name:tool ~input ~context
112
+
in
113
+
114
+
(* Show result *)
115
+
match result with
116
+
| Claude.Permissions.Result.Allow _ ->
117
+
Log.info (fun m -> m "Result: Permission granted for %s" tool)
118
+
| Claude.Permissions.Result.Deny { message; _ } ->
119
+
Log.info (fun m ->
120
+
m "Result: Permission denied for %s - %s" tool message))
121
+
tools;
122
+
112
123
(* Show final state *)
113
124
PermissionState.show ()
114
125
···
116
127
let demo_discovery () =
117
128
Log.app (fun m -> m "\n\n🔍 Discovery Callback Demonstration");
118
129
Log.app (fun m -> m "====================================\n");
119
-
130
+
120
131
let discovered = ref [] in
121
132
let callback = Claude.Permissions.discovery_callback discovered in
122
-
133
+
123
134
(* Simulate some tool requests *)
124
135
let requests =
125
136
let open Jsont in
126
137
[
127
-
("Read", Object ([
128
-
(("file_path", Meta.none), String ("test.ml", Meta.none))
129
-
], Meta.none));
130
-
("Bash", Object ([
131
-
(("command", Meta.none), String ("ls -la", Meta.none))
132
-
], Meta.none));
133
-
("Write", Object ([
134
-
(("file_path", Meta.none), String ("output.txt", Meta.none))
135
-
], Meta.none));
138
+
( "Read",
139
+
Object
140
+
( [ (("file_path", Meta.none), String ("test.ml", Meta.none)) ],
141
+
Meta.none ) );
142
+
( "Bash",
143
+
Object
144
+
([ (("command", Meta.none), String ("ls -la", Meta.none)) ], Meta.none)
145
+
);
146
+
( "Write",
147
+
Object
148
+
( [ (("file_path", Meta.none), String ("output.txt", Meta.none)) ],
149
+
Meta.none ) );
136
150
]
137
151
in
138
-
152
+
139
153
Log.app (fun m -> m "Simulating tool requests with discovery callback...\n");
140
-
141
-
List.iter (fun (tool, input) ->
142
-
Log.app (fun m -> m " Request: %s" tool);
143
-
let context = Claude.Permissions.Context.create () in
144
-
let _ = callback ~tool_name:tool ~input ~context in
145
-
()
146
-
) requests;
147
-
154
+
155
+
List.iter
156
+
(fun (tool, input) ->
157
+
Log.app (fun m -> m " Request: %s" tool);
158
+
let context = Claude.Permissions.Context.create () in
159
+
let _ = callback ~tool_name:tool ~input ~context in
160
+
())
161
+
requests;
162
+
148
163
Log.app (fun m -> m "\n📋 Discovered permissions:");
149
-
if !discovered = [] then
150
-
Log.app (fun m -> m " None")
164
+
if !discovered = [] then Log.app (fun m -> m " None")
151
165
else
152
-
List.iter (fun rule ->
153
-
Log.app (fun m -> m " - %s%s"
154
-
(Claude.Permissions.Rule.tool_name rule)
155
-
(match Claude.Permissions.Rule.rule_content rule with
156
-
| Some content -> Printf.sprintf " (content: %s)" content
157
-
| None -> ""))
158
-
) !discovered
166
+
List.iter
167
+
(fun rule ->
168
+
Log.app (fun m ->
169
+
m " - %s%s"
170
+
(Claude.Permissions.Rule.tool_name rule)
171
+
(match Claude.Permissions.Rule.rule_content rule with
172
+
| Some content -> Printf.sprintf " (content: %s)" content
173
+
| None -> "")))
174
+
!discovered
159
175
160
176
let main () =
161
177
demo_permissions ();
···
179
195
180
196
let cmd =
181
197
let doc = "Demonstrate permission callbacks and discovery" in
182
-
let man = [
183
-
`S Manpage.s_description;
184
-
`P "This program demonstrates how permission callbacks work in the Claude OCaml library.";
185
-
`P "It simulates permission requests and shows how to implement custom callbacks.";
186
-
] in
198
+
let man =
199
+
[
200
+
`S Manpage.s_description;
201
+
`P
202
+
"This program demonstrates how permission callbacks work in the Claude \
203
+
OCaml library.";
204
+
`P
205
+
"It simulates permission requests and shows how to implement custom \
206
+
callbacks.";
207
+
]
208
+
in
187
209
let info = Cmd.info "simulated_permissions" ~version:"1.0" ~doc ~man in
188
210
Cmd.v info main_term
189
211
190
-
let () = exit (Cmd.eval cmd)
212
+
let () = exit (Cmd.eval cmd)
+155
-103
test/structured_output_demo.ml
+155
-103
test/structured_output_demo.ml
···
14
14
(* Define the JSON Schema for our expected output structure *)
15
15
let analysis_schema =
16
16
let open Jsont in
17
-
Object ([
18
-
(("type", Meta.none), String ("object", Meta.none));
19
-
(("properties", Meta.none), Object ([
20
-
(("file_count", Meta.none), Object ([
21
-
(("type", Meta.none), String ("integer", Meta.none));
22
-
(("description", Meta.none), String ("Total number of files analyzed", Meta.none))
23
-
], Meta.none));
24
-
(("has_tests", Meta.none), Object ([
25
-
(("type", Meta.none), String ("boolean", Meta.none));
26
-
(("description", Meta.none), String ("Whether the codebase has test files", Meta.none))
27
-
], Meta.none));
28
-
(("primary_language", Meta.none), Object ([
29
-
(("type", Meta.none), String ("string", Meta.none));
30
-
(("description", Meta.none), String ("The primary programming language used", Meta.none))
31
-
], Meta.none));
32
-
(("complexity_rating", Meta.none), Object ([
33
-
(("type", Meta.none), String ("string", Meta.none));
34
-
(("enum", Meta.none), Array ([
35
-
String ("low", Meta.none);
36
-
String ("medium", Meta.none);
37
-
String ("high", Meta.none)
38
-
], Meta.none));
39
-
(("description", Meta.none), String ("Overall complexity rating", Meta.none))
40
-
], Meta.none));
41
-
(("key_findings", Meta.none), Object ([
42
-
(("type", Meta.none), String ("array", Meta.none));
43
-
(("items", Meta.none), Object ([
44
-
(("type", Meta.none), String ("string", Meta.none))
45
-
], Meta.none));
46
-
(("description", Meta.none), String ("List of key findings from the analysis", Meta.none))
47
-
], Meta.none));
48
-
], Meta.none));
49
-
(("required", Meta.none), Array ([
50
-
String ("file_count", Meta.none);
51
-
String ("has_tests", Meta.none);
52
-
String ("primary_language", Meta.none);
53
-
String ("complexity_rating", Meta.none);
54
-
String ("key_findings", Meta.none)
55
-
], Meta.none));
56
-
(("additionalProperties", Meta.none), Bool (false, Meta.none))
57
-
], Meta.none)
17
+
Object
18
+
( [
19
+
(("type", Meta.none), String ("object", Meta.none));
20
+
( ("properties", Meta.none),
21
+
Object
22
+
( [
23
+
( ("file_count", Meta.none),
24
+
Object
25
+
( [
26
+
(("type", Meta.none), String ("integer", Meta.none));
27
+
( ("description", Meta.none),
28
+
String ("Total number of files analyzed", Meta.none)
29
+
);
30
+
],
31
+
Meta.none ) );
32
+
( ("has_tests", Meta.none),
33
+
Object
34
+
( [
35
+
(("type", Meta.none), String ("boolean", Meta.none));
36
+
( ("description", Meta.none),
37
+
String
38
+
("Whether the codebase has test files", Meta.none)
39
+
);
40
+
],
41
+
Meta.none ) );
42
+
( ("primary_language", Meta.none),
43
+
Object
44
+
( [
45
+
(("type", Meta.none), String ("string", Meta.none));
46
+
( ("description", Meta.none),
47
+
String
48
+
( "The primary programming language used",
49
+
Meta.none ) );
50
+
],
51
+
Meta.none ) );
52
+
( ("complexity_rating", Meta.none),
53
+
Object
54
+
( [
55
+
(("type", Meta.none), String ("string", Meta.none));
56
+
( ("enum", Meta.none),
57
+
Array
58
+
( [
59
+
String ("low", Meta.none);
60
+
String ("medium", Meta.none);
61
+
String ("high", Meta.none);
62
+
],
63
+
Meta.none ) );
64
+
( ("description", Meta.none),
65
+
String ("Overall complexity rating", Meta.none) );
66
+
],
67
+
Meta.none ) );
68
+
( ("key_findings", Meta.none),
69
+
Object
70
+
( [
71
+
(("type", Meta.none), String ("array", Meta.none));
72
+
( ("items", Meta.none),
73
+
Object
74
+
( [
75
+
( ("type", Meta.none),
76
+
String ("string", Meta.none) );
77
+
],
78
+
Meta.none ) );
79
+
( ("description", Meta.none),
80
+
String
81
+
( "List of key findings from the analysis",
82
+
Meta.none ) );
83
+
],
84
+
Meta.none ) );
85
+
],
86
+
Meta.none ) );
87
+
( ("required", Meta.none),
88
+
Array
89
+
( [
90
+
String ("file_count", Meta.none);
91
+
String ("has_tests", Meta.none);
92
+
String ("primary_language", Meta.none);
93
+
String ("complexity_rating", Meta.none);
94
+
String ("key_findings", Meta.none);
95
+
],
96
+
Meta.none ) );
97
+
(("additionalProperties", Meta.none), Bool (false, Meta.none));
98
+
],
99
+
Meta.none )
58
100
in
59
101
60
102
(* Create structured output format from the schema *)
61
103
let output_format = C.Structured_output.of_json_schema analysis_schema in
62
104
63
105
(* Configure Claude with structured output *)
64
-
let options = C.Options.default
106
+
let options =
107
+
C.Options.default
65
108
|> C.Options.with_output_format output_format
66
-
|> C.Options.with_allowed_tools ["Read"; "Glob"; "Grep"]
109
+
|> C.Options.with_allowed_tools [ "Read"; "Glob"; "Grep" ]
67
110
|> C.Options.with_system_prompt
68
111
"You are a code analysis assistant. Analyze codebases and provide \
69
112
structured output matching the given JSON Schema."
···
75
118
76
119
(* Create Claude client and query *)
77
120
Eio.Switch.run @@ fun sw ->
78
-
let process_mgr = Eio.Stdenv.process_mgr env in
79
-
let client = C.Client.create ~sw ~process_mgr ~options () in
121
+
let process_mgr = Eio.Stdenv.process_mgr env in
122
+
let client = C.Client.create ~sw ~process_mgr ~options () in
80
123
81
-
let prompt =
82
-
"Please analyze the current codebase structure. Look at the files, \
83
-
identify the primary language, count files, check for tests, assess \
84
-
complexity, and provide key findings. Return your analysis in the \
85
-
structured JSON format I specified."
86
-
in
124
+
let prompt =
125
+
"Please analyze the current codebase structure. Look at the files, \
126
+
identify the primary language, count files, check for tests, assess \
127
+
complexity, and provide key findings. Return your analysis in the \
128
+
structured JSON format I specified."
129
+
in
87
130
88
-
Printf.printf "Sending query: %s\n\n" prompt;
89
-
C.Client.query client prompt;
131
+
Printf.printf "Sending query: %s\n\n" prompt;
132
+
C.Client.query client prompt;
90
133
91
-
(* Process responses *)
92
-
let messages = C.Client.receive client in
93
-
Seq.iter (function
134
+
(* Process responses *)
135
+
let messages = C.Client.receive client in
136
+
Seq.iter
137
+
(function
94
138
| C.Message.Assistant msg ->
95
139
Printf.printf "\nAssistant response:\n";
96
-
List.iter (function
97
-
| C.Content_block.Text text ->
98
-
Printf.printf " Text: %s\n" (C.Content_block.Text.text text)
99
-
| C.Content_block.Tool_use tool ->
100
-
Printf.printf " Using tool: %s\n" (C.Content_block.Tool_use.name tool)
101
-
| _ -> ()
102
-
) (C.Message.Assistant.content msg)
103
-
104
-
| C.Message.Result result ->
140
+
List.iter
141
+
(function
142
+
| C.Content_block.Text text ->
143
+
Printf.printf " Text: %s\n" (C.Content_block.Text.text text)
144
+
| C.Content_block.Tool_use tool ->
145
+
Printf.printf " Using tool: %s\n"
146
+
(C.Content_block.Tool_use.name tool)
147
+
| _ -> ())
148
+
(C.Message.Assistant.content msg)
149
+
| C.Message.Result result -> (
105
150
Printf.printf "\n=== Result ===\n";
106
151
Printf.printf "Duration: %dms\n" (C.Message.Result.duration_ms result);
107
152
Printf.printf "Cost: $%.4f\n"
108
153
(Option.value (C.Message.Result.total_cost_usd result) ~default:0.0);
109
154
110
155
(* Extract and display structured output *)
111
-
(match C.Message.Result.structured_output result with
156
+
match C.Message.Result.structured_output result with
112
157
| Some output ->
113
158
Printf.printf "\n=== Structured Output ===\n";
114
-
Printf.printf "%s\n\n" (Test_json_utils.to_string ~minify:false output);
159
+
Printf.printf "%s\n\n"
160
+
(Test_json_utils.to_string ~minify:false output);
115
161
116
162
(* Parse the structured output *)
117
-
let file_count = Test_json_utils.get_int output "file_count" |> Option.value ~default:0 in
118
-
let has_tests = Test_json_utils.get_bool output "has_tests" |> Option.value ~default:false in
119
-
let language = Test_json_utils.get_string output "primary_language" |> Option.value ~default:"unknown" in
120
-
let complexity = Test_json_utils.get_string output "complexity_rating" |> Option.value ~default:"unknown" in
163
+
let file_count =
164
+
Test_json_utils.get_int output "file_count"
165
+
|> Option.value ~default:0
166
+
in
167
+
let has_tests =
168
+
Test_json_utils.get_bool output "has_tests"
169
+
|> Option.value ~default:false
170
+
in
171
+
let language =
172
+
Test_json_utils.get_string output "primary_language"
173
+
|> Option.value ~default:"unknown"
174
+
in
175
+
let complexity =
176
+
Test_json_utils.get_string output "complexity_rating"
177
+
|> Option.value ~default:"unknown"
178
+
in
121
179
let findings =
122
180
match Test_json_utils.get_array output "key_findings" with
123
181
| Some items ->
124
-
List.filter_map (fun json ->
125
-
Test_json_utils.as_string json
126
-
) items
182
+
List.filter_map
183
+
(fun json -> Test_json_utils.as_string json)
184
+
items
127
185
| None -> []
128
186
in
129
187
···
133
191
Printf.printf "Primary Language: %s\n" language;
134
192
Printf.printf "Complexity: %s\n" complexity;
135
193
Printf.printf "Key Findings:\n";
136
-
List.iter (fun finding ->
137
-
Printf.printf " - %s\n" finding
138
-
) findings
139
-
140
-
| None ->
194
+
List.iter
195
+
(fun finding -> Printf.printf " - %s\n" finding)
196
+
findings
197
+
| None -> (
141
198
Printf.printf "No structured output received\n";
142
-
(match C.Message.Result.result result with
199
+
match C.Message.Result.result result with
143
200
| Some text -> Printf.printf "Text result: %s\n" text
144
201
| None -> ()))
145
-
146
-
| C.Message.System sys ->
147
-
(match C.Message.System.subtype sys with
148
-
| "init" ->
149
-
Printf.printf "Session initialized\n"
202
+
| C.Message.System sys -> (
203
+
match C.Message.System.subtype sys with
204
+
| "init" -> Printf.printf "Session initialized\n"
150
205
| _ -> ())
151
-
152
-
| _ -> ()
153
-
) messages;
206
+
| _ -> ())
207
+
messages;
154
208
155
-
Printf.printf "\nDone!\n"
209
+
Printf.printf "\nDone!\n"
156
210
157
211
let () =
158
212
Eio_main.run @@ fun env ->
159
-
try
160
-
run_codebase_analysis env
161
-
with
162
-
| C.Transport.CLI_not_found msg ->
163
-
Printf.eprintf "Error: Claude CLI not found\n%s\n" msg;
164
-
Printf.eprintf "Make sure 'claude' is installed and in your PATH\n";
165
-
exit 1
166
-
| C.Transport.Connection_error msg ->
167
-
Printf.eprintf "Connection error: %s\n" msg;
168
-
exit 1
169
-
| exn ->
170
-
Printf.eprintf "Unexpected error: %s\n" (Printexc.to_string exn);
171
-
Printexc.print_backtrace stderr;
172
-
exit 1
213
+
try run_codebase_analysis env with
214
+
| C.Transport.CLI_not_found msg ->
215
+
Printf.eprintf "Error: Claude CLI not found\n%s\n" msg;
216
+
Printf.eprintf "Make sure 'claude' is installed and in your PATH\n";
217
+
exit 1
218
+
| C.Transport.Connection_error msg ->
219
+
Printf.eprintf "Connection error: %s\n" msg;
220
+
exit 1
221
+
| exn ->
222
+
Printf.eprintf "Unexpected error: %s\n" (Printexc.to_string exn);
223
+
Printexc.print_backtrace stderr;
224
+
exit 1
+49
-38
test/structured_output_simple.ml
+49
-38
test/structured_output_simple.ml
···
12
12
(* Define a simple schema for a person's info *)
13
13
let person_schema =
14
14
let open Jsont in
15
-
Object ([
16
-
(("type", Meta.none), String ("object", Meta.none));
17
-
(("properties", Meta.none), Object ([
18
-
(("name", Meta.none), Object ([
19
-
(("type", Meta.none), String ("string", Meta.none))
20
-
], Meta.none));
21
-
(("age", Meta.none), Object ([
22
-
(("type", Meta.none), String ("integer", Meta.none))
23
-
], Meta.none));
24
-
(("occupation", Meta.none), Object ([
25
-
(("type", Meta.none), String ("string", Meta.none))
26
-
], Meta.none));
27
-
], Meta.none));
28
-
(("required", Meta.none), Array ([
29
-
String ("name", Meta.none);
30
-
String ("age", Meta.none);
31
-
String ("occupation", Meta.none)
32
-
], Meta.none))
33
-
], Meta.none)
15
+
Object
16
+
( [
17
+
(("type", Meta.none), String ("object", Meta.none));
18
+
( ("properties", Meta.none),
19
+
Object
20
+
( [
21
+
( ("name", Meta.none),
22
+
Object
23
+
( [ (("type", Meta.none), String ("string", Meta.none)) ],
24
+
Meta.none ) );
25
+
( ("age", Meta.none),
26
+
Object
27
+
( [ (("type", Meta.none), String ("integer", Meta.none)) ],
28
+
Meta.none ) );
29
+
( ("occupation", Meta.none),
30
+
Object
31
+
( [ (("type", Meta.none), String ("string", Meta.none)) ],
32
+
Meta.none ) );
33
+
],
34
+
Meta.none ) );
35
+
( ("required", Meta.none),
36
+
Array
37
+
( [
38
+
String ("name", Meta.none);
39
+
String ("age", Meta.none);
40
+
String ("occupation", Meta.none);
41
+
],
42
+
Meta.none ) );
43
+
],
44
+
Meta.none )
34
45
in
35
46
36
47
let output_format = C.Structured_output.of_json_schema person_schema in
37
48
38
-
let options = C.Options.default
49
+
let options =
50
+
C.Options.default
39
51
|> C.Options.with_output_format output_format
40
52
|> C.Options.with_max_turns 1
41
53
in
···
43
55
Printf.printf "Asking Claude to provide structured data...\n\n";
44
56
45
57
Eio.Switch.run @@ fun sw ->
46
-
let process_mgr = Eio.Stdenv.process_mgr env in
47
-
let client = C.Client.create ~sw ~process_mgr ~options () in
58
+
let process_mgr = Eio.Stdenv.process_mgr env in
59
+
let client = C.Client.create ~sw ~process_mgr ~options () in
48
60
49
-
C.Client.query client
50
-
"Tell me about a famous computer scientist. Provide their name, age, \
51
-
and occupation in the exact JSON structure I specified.";
61
+
C.Client.query client
62
+
"Tell me about a famous computer scientist. Provide their name, age, and \
63
+
occupation in the exact JSON structure I specified.";
52
64
53
-
let messages = C.Client.receive_all client in
54
-
List.iter (function
55
-
| C.Message.Result result ->
65
+
let messages = C.Client.receive_all client in
66
+
List.iter
67
+
(function
68
+
| C.Message.Result result -> (
56
69
Printf.printf "Response received!\n";
57
-
(match C.Message.Result.structured_output result with
70
+
match C.Message.Result.structured_output result with
58
71
| Some json ->
59
72
Printf.printf "\nStructured Output:\n%s\n"
60
73
(Test_json_utils.to_string ~minify:false json)
61
-
| None ->
62
-
Printf.printf "No structured output\n")
63
-
| _ -> ()
64
-
) messages
74
+
| None -> Printf.printf "No structured output\n")
75
+
| _ -> ())
76
+
messages
65
77
66
78
let () =
67
79
Eio_main.run @@ fun env ->
68
-
try
69
-
simple_example env
70
-
with exn ->
71
-
Printf.eprintf "Error: %s\n" (Printexc.to_string exn);
72
-
exit 1
80
+
try simple_example env
81
+
with exn ->
82
+
Printf.eprintf "Error: %s\n" (Printexc.to_string exn);
83
+
exit 1
+35
-29
test/test_incoming.ml
+35
-29
test/test_incoming.ml
···
7
7
match Jsont_bytesrw.decode_string' Incoming.jsont json_str with
8
8
| Ok (Incoming.Message (Message.User _)) ->
9
9
print_endline "✓ Decoded user message successfully"
10
-
| Ok _ ->
11
-
print_endline "✗ Wrong message type decoded"
10
+
| Ok _ -> print_endline "✗ Wrong message type decoded"
12
11
| Error err ->
13
-
Printf.printf "✗ Failed to decode user message: %s\n" (Jsont.Error.to_string err)
12
+
Printf.printf "✗ Failed to decode user message: %s\n"
13
+
(Jsont.Error.to_string err)
14
14
15
15
let test_decode_assistant_message () =
16
-
let json_str = {|{"type":"assistant","model":"claude-sonnet-4","content":[{"type":"text","text":"Hi"}]}|} in
16
+
let json_str =
17
+
{|{"type":"assistant","model":"claude-sonnet-4","content":[{"type":"text","text":"Hi"}]}|}
18
+
in
17
19
match Jsont_bytesrw.decode_string' Incoming.jsont json_str with
18
20
| Ok (Incoming.Message (Message.Assistant _)) ->
19
21
print_endline "✓ Decoded assistant message successfully"
20
-
| Ok _ ->
21
-
print_endline "✗ Wrong message type decoded"
22
+
| Ok _ -> print_endline "✗ Wrong message type decoded"
22
23
| Error err ->
23
-
Printf.printf "✗ Failed to decode assistant message: %s\n" (Jsont.Error.to_string err)
24
+
Printf.printf "✗ Failed to decode assistant message: %s\n"
25
+
(Jsont.Error.to_string err)
24
26
25
27
let test_decode_system_message () =
26
-
let json_str = {|{"type":"system","subtype":"init","data":{"session_id":"test-123"}}|} in
28
+
let json_str =
29
+
{|{"type":"system","subtype":"init","data":{"session_id":"test-123"}}|}
30
+
in
27
31
match Jsont_bytesrw.decode_string' Incoming.jsont json_str with
28
32
| Ok (Incoming.Message (Message.System _)) ->
29
33
print_endline "✓ Decoded system message successfully"
30
-
| Ok _ ->
31
-
print_endline "✗ Wrong message type decoded"
34
+
| Ok _ -> print_endline "✗ Wrong message type decoded"
32
35
| Error err ->
33
-
Printf.printf "✗ Failed to decode system message: %s\n" (Jsont.Error.to_string err)
36
+
Printf.printf "✗ Failed to decode system message: %s\n"
37
+
(Jsont.Error.to_string err)
34
38
35
39
let test_decode_control_response () =
36
-
let json_str = {|{"type":"control_response","response":{"subtype":"success","request_id":"test-req-1"}}|} in
40
+
let json_str =
41
+
{|{"type":"control_response","response":{"subtype":"success","request_id":"test-req-1"}}|}
42
+
in
37
43
match Jsont_bytesrw.decode_string' Incoming.jsont json_str with
38
-
| Ok (Incoming.Control_response resp) ->
39
-
(match resp.response with
44
+
| Ok (Incoming.Control_response resp) -> (
45
+
match resp.response with
40
46
| Sdk_control.Response.Success s ->
41
47
if s.request_id = "test-req-1" then
42
48
print_endline "✓ Decoded control response successfully"
43
-
else
44
-
Printf.printf "✗ Wrong request_id: %s\n" s.request_id
49
+
else Printf.printf "✗ Wrong request_id: %s\n" s.request_id
45
50
| Sdk_control.Response.Error _ ->
46
51
print_endline "✗ Got error response instead of success")
47
-
| Ok _ ->
48
-
print_endline "✗ Wrong message type decoded"
52
+
| Ok _ -> print_endline "✗ Wrong message type decoded"
49
53
| Error err ->
50
-
Printf.printf "✗ Failed to decode control response: %s\n" (Jsont.Error.to_string err)
54
+
Printf.printf "✗ Failed to decode control response: %s\n"
55
+
(Jsont.Error.to_string err)
51
56
52
57
let test_decode_control_response_error () =
53
-
let json_str = {|{"type":"control_response","response":{"subtype":"error","request_id":"test-req-2","error":"Something went wrong"}}|} in
58
+
let json_str =
59
+
{|{"type":"control_response","response":{"subtype":"error","request_id":"test-req-2","error":"Something went wrong"}}|}
60
+
in
54
61
match Jsont_bytesrw.decode_string' Incoming.jsont json_str with
55
-
| Ok (Incoming.Control_response resp) ->
56
-
(match resp.response with
62
+
| Ok (Incoming.Control_response resp) -> (
63
+
match resp.response with
57
64
| Sdk_control.Response.Error e ->
58
-
if e.request_id = "test-req-2" && e.error = "Something went wrong" then
59
-
print_endline "✓ Decoded control error response successfully"
60
-
else
61
-
Printf.printf "✗ Wrong error content\n"
65
+
if e.request_id = "test-req-2" && e.error = "Something went wrong"
66
+
then print_endline "✓ Decoded control error response successfully"
67
+
else Printf.printf "✗ Wrong error content\n"
62
68
| Sdk_control.Response.Success _ ->
63
69
print_endline "✗ Got success response instead of error")
64
-
| Ok _ ->
65
-
print_endline "✗ Wrong message type decoded"
70
+
| Ok _ -> print_endline "✗ Wrong message type decoded"
66
71
| Error err ->
67
-
Printf.printf "✗ Failed to decode control error response: %s\n" (Jsont.Error.to_string err)
72
+
Printf.printf "✗ Failed to decode control error response: %s\n"
73
+
(Jsont.Error.to_string err)
68
74
69
75
let () =
70
76
print_endline "Testing Incoming message codec...";
+5
-8
test/test_json_utils.ml
+5
-8
test/test_json_utils.ml
···
1
1
(* Helper functions for JSON operations in tests using jsont codecs *)
2
2
3
-
let to_string ?(minify=false) json =
3
+
let to_string ?(minify = false) json =
4
4
let format = if minify then Jsont.Minify else Jsont.Indent in
5
5
match Jsont_bytesrw.encode_string' ~format Jsont.json json with
6
6
| Ok s -> s
···
8
8
9
9
(* Helper to decode an optional field with a given codec *)
10
10
let get_opt (type a) (codec : a Jsont.t) json key : a option =
11
-
let field_codec = Jsont.Object.map ~kind:"field" (fun v -> v)
11
+
let field_codec =
12
+
Jsont.Object.map ~kind:"field" (fun v -> v)
12
13
|> Jsont.Object.opt_mem key codec ~enc:Fun.id
13
14
|> Jsont.Object.finish
14
15
in
15
-
match Jsont.Json.decode field_codec json with
16
-
| Ok v -> v
17
-
| Error _ -> None
16
+
match Jsont.Json.decode field_codec json with Ok v -> v | Error _ -> None
18
17
19
18
let get_string json key = get_opt Jsont.string json key
20
19
let get_int json key = get_opt Jsont.int json key
21
20
let get_bool json key = get_opt Jsont.bool json key
22
-
23
-
let get_array json key =
24
-
get_opt (Jsont.list Jsont.json) json key
21
+
let get_array json key = get_opt (Jsont.list Jsont.json) json key
25
22
26
23
let as_string json =
27
24
match Jsont.Json.decode Jsont.string json with
+34
-36
test/test_permissions.ml
+34
-36
test/test_permissions.ml
···
1
1
open Eio.Std
2
2
3
3
let src = Logs.Src.create "test_permissions" ~doc:"Permission callback test"
4
+
4
5
module Log = (val Logs.src_log src : Logs.LOG)
5
6
6
7
(* Simple auto-allow permission callback *)
···
13
14
Log.app (fun m -> m "================================");
14
15
15
16
(* Create options with custom permission callback *)
16
-
let options = Claude.Options.create
17
-
~model:(Claude.Model.of_string "sonnet")
18
-
~permission_callback:auto_allow_callback
19
-
() in
17
+
let options =
18
+
Claude.Options.create
19
+
~model:(Claude.Model.of_string "sonnet")
20
+
~permission_callback:auto_allow_callback ()
21
+
in
20
22
21
23
Log.app (fun m -> m "Creating client with permission callback...");
22
-
let client = Claude.Client.create ~options ~sw
23
-
~process_mgr:env#process_mgr
24
-
() in
24
+
let client =
25
+
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr ()
26
+
in
25
27
26
28
(* Simple query that will trigger tool use *)
27
29
Log.app (fun m -> m "\n📤 Sending test query...");
28
-
Claude.Client.query client
29
-
"What is 2 + 2? Just give me the number.";
30
+
Claude.Client.query client "What is 2 + 2? Just give me the number.";
30
31
31
32
(* Process response *)
32
33
let messages = Claude.Client.receive_all client in
33
34
Log.app (fun m -> m "\n📨 Received %d messages" (List.length messages));
34
35
35
-
List.iter (fun msg ->
36
-
match msg with
37
-
| Claude.Message.Assistant msg ->
38
-
List.iter (function
39
-
| Claude.Content_block.Text t ->
40
-
let text = Claude.Content_block.Text.text t in
41
-
Log.app (fun m -> m "Claude: %s" text)
42
-
| Claude.Content_block.Tool_use t ->
43
-
Log.app (fun m -> m "🔧 Tool use: %s"
44
-
(Claude.Content_block.Tool_use.name t))
45
-
| _ -> ()
46
-
) (Claude.Message.Assistant.content msg)
47
-
| Claude.Message.Result msg ->
48
-
if Claude.Message.Result.is_error msg then
49
-
Log.err (fun m -> m "❌ Error occurred!")
50
-
else
51
-
Log.app (fun m -> m "✅ Success!");
52
-
Log.app (fun m -> m "Duration: %dms"
53
-
(Claude.Message.Result.duration_ms msg))
54
-
| _ -> ()
55
-
) messages;
36
+
List.iter
37
+
(fun msg ->
38
+
match msg with
39
+
| Claude.Message.Assistant msg ->
40
+
List.iter
41
+
(function
42
+
| Claude.Content_block.Text t ->
43
+
let text = Claude.Content_block.Text.text t in
44
+
Log.app (fun m -> m "Claude: %s" text)
45
+
| Claude.Content_block.Tool_use t ->
46
+
Log.app (fun m ->
47
+
m "🔧 Tool use: %s" (Claude.Content_block.Tool_use.name t))
48
+
| _ -> ())
49
+
(Claude.Message.Assistant.content msg)
50
+
| Claude.Message.Result msg ->
51
+
if Claude.Message.Result.is_error msg then
52
+
Log.err (fun m -> m "❌ Error occurred!")
53
+
else Log.app (fun m -> m "✅ Success!");
54
+
Log.app (fun m ->
55
+
m "Duration: %dms" (Claude.Message.Result.duration_ms msg))
56
+
| _ -> ())
57
+
messages;
56
58
57
59
Log.app (fun m -> m "\n================================");
58
60
Log.app (fun m -> m "✨ Test complete!")
59
61
60
-
let main ~env =
61
-
Switch.run @@ fun sw ->
62
-
run_test ~sw ~env
62
+
let main ~env = Switch.run @@ fun sw -> run_test ~sw ~env
63
63
64
64
(* Command-line interface *)
65
65
open Cmdliner
···
86
86
let info = Cmd.info "test_permissions" ~version:"1.0" ~doc in
87
87
Cmd.v info (main_term env)
88
88
89
-
let () =
90
-
Eio_main.run @@ fun env ->
91
-
exit (Cmd.eval (cmd env))
89
+
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))