anil.recoil.org
OCaml Claude SDK using Eio and Jsont
switch to proto subpackage
+6861
-3224
+9
-7
lib/claude.ml
+9
-7
lib/claude.ml
···
1
-
module Model = Model
1
+
module Err = Err
2
+
module Client = Client
3
+
module Options = Options
4
+
module Response = Response
5
+
module Handler = Handler
6
+
module Tool_input = Tool_input
2
7
module Content_block = Content_block
3
8
module Message = Message
4
-
module Control = Control
5
9
module Permissions = Permissions
6
10
module Hooks = Hooks
7
-
module Sdk_control = Sdk_control
8
-
module Incoming = Incoming
9
-
module Structured_output = Structured_output
10
-
module Options = Options
11
+
module Server_info = Server_info
11
12
module Transport = Transport
12
-
module Client = Client
13
+
module Model = Model
14
+
module Proto = Proto
+138
-104
lib/claude.mli
+138
-104
lib/claude.mli
···
15
15
16
16
{1 Architecture}
17
17
18
-
The library is structured into several focused modules:
18
+
The library is structured into two layers:
19
19
20
-
- {!Content_block}: Defines content blocks (text, tool use, tool results,
21
-
thinking)
22
-
- {!Message}: Messages exchanged with Claude (user, assistant, system,
23
-
result)
24
-
- {!Control}: Control flow messages for session management
20
+
{2 High-Level API}
21
+
- {!Client}: High-level client interface for interacting with Claude
22
+
- {!Response}: High-level response events from Claude
23
+
- {!Handler}: Object-oriented response handler with sensible defaults
24
+
- {!Options}: Configuration options for Claude sessions
25
25
- {!Permissions}: Fine-grained permission system for tool usage
26
-
- {!Options}: Configuration options for Claude sessions
27
-
- {!Transport}: Low-level transport layer for CLI communication
28
-
- {!Client}: High-level client interface for interacting with Claude
26
+
- {!Hooks}: Fully typed hook callbacks for event interception
27
+
28
+
{2 Domain Types}
29
+
- {!Content_block}: Content blocks (text, tool use, tool results, thinking)
30
+
- {!Message}: Messages exchanged with Claude (user, assistant, system, result)
31
+
- {!Tool_input}: Opaque tool input with typed accessors
32
+
- {!Server_info}: Server capabilities and metadata
33
+
34
+
{2 Wire Format (Advanced)}
35
+
- {!Proto}: Direct access to wire-format types and JSON codecs
29
36
30
-
{1 Basic Usage}
37
+
{1 Quick Start}
31
38
32
39
{[
33
-
open Claude
40
+
open Eio.Std
41
+
42
+
let () = Eio_main.run @@ fun env ->
43
+
Switch.run @@ fun sw ->
44
+
let client = Claude.Client.create ~sw
45
+
~process_mgr:(Eio.Stdenv.process_mgr env) () in
34
46
35
-
(* Create a simple query *)
36
-
let query_claude ~sw env prompt =
37
-
let options = Options.default in
38
-
Client.query ~sw env ~options prompt
47
+
Claude.Client.query client "What is 2+2?";
39
48
40
-
(* Process streaming responses *)
41
-
let process_response 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
+
let handler = object
50
+
inherit Claude.Handler.default
51
+
method! on_text t = print_endline (Claude.Response.Text.content t)
52
+
end in
53
+
54
+
Claude.Client.run client ~handler
53
55
]}
54
56
55
-
{1 Advanced Features}
57
+
{1 Response Handling}
58
+
59
+
The library provides two ways to handle responses:
56
60
57
-
{2 Tool Permissions}
61
+
{2 Object-Oriented Handler (Recommended)}
58
62
59
-
Control which tools Claude can use and how:
63
+
Subclass {!Handler.default} and override only the methods you need:
60
64
61
65
{[
62
-
let options =
63
-
Options.default
64
-
|> Options.with_allowed_tools [ "Read"; "Write"; "Bash" ]
65
-
|> Options.with_permission_mode Permissions.Mode.Accept_edits
66
+
let my_handler = object
67
+
inherit Claude.Handler.default
68
+
69
+
method! on_text t =
70
+
print_endline (Claude.Response.Text.content t)
71
+
72
+
method! on_tool_use t =
73
+
Printf.printf "Tool: %s\n" (Claude.Response.Tool_use.name t)
74
+
75
+
method! on_complete c =
76
+
Printf.printf "Done! Cost: $%.4f\n"
77
+
(Option.value ~default:0.0 (Claude.Response.Complete.total_cost_usd c))
78
+
end in
79
+
80
+
Claude.Client.run client ~handler:my_handler
66
81
]}
67
82
68
-
{2 Custom Permission Callbacks}
83
+
{2 Functional Sequence}
69
84
70
-
Implement custom logic for tool approval:
85
+
For more control, use {!Client.receive} to get a lazy sequence:
71
86
72
87
{[
73
-
let my_callback ~tool_name ~input ~context =
74
-
if tool_name = "Bash" then
75
-
Permissions.Result.deny ~message:"Bash not allowed" ~interrupt:false
76
-
else Permissions.Result.allow ()
88
+
Claude.Client.receive client
89
+
|> Seq.iter (function
90
+
| Claude.Response.Text t -> print_endline (Claude.Response.Text.content t)
91
+
| Claude.Response.Complete c -> Printf.printf "Done!\n"
92
+
| _ -> ())
93
+
]}
94
+
95
+
{1 Tool Permissions}
96
+
97
+
Control which tools Claude can use:
77
98
99
+
{[
78
100
let options =
79
-
Options.default |> Options.with_permission_callback my_callback
101
+
Claude.Options.default
102
+
|> Claude.Options.with_allowed_tools [ "Read"; "Write"; "Bash" ]
103
+
|> Claude.Options.with_permission_mode Claude.Permissions.Mode.Accept_edits
80
104
]}
81
105
82
-
{2 System Prompts}
106
+
{2 Custom Permission Callbacks}
83
107
84
-
Customize Claude's behavior with system prompts:
108
+
Implement custom logic for tool approval:
85
109
86
110
{[
111
+
let my_callback ctx =
112
+
if ctx.Claude.Permissions.tool_name = "Bash" then
113
+
Claude.Permissions.Decision.deny ~message:"Bash not allowed" ~interrupt:false
114
+
else
115
+
Claude.Permissions.Decision.allow ()
116
+
87
117
let options =
88
-
Options.default
89
-
|> Options.with_system_prompt
90
-
"You are a helpful OCaml programming assistant."
91
-
|> Options.with_append_system_prompt "Always use Jane Street style."
118
+
Claude.Options.default
119
+
|> Claude.Options.with_permission_callback my_callback
92
120
]}
93
121
94
-
{1 Logging}
122
+
{1 Typed Hooks}
95
123
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:
124
+
Intercept and control tool execution with fully typed callbacks:
99
125
100
126
{[
101
-
(* Enable debug logging for message handling *)
102
-
Logs.Src.set_level Message.src (Some Logs.Debug);
127
+
let hooks =
128
+
Claude.Hooks.empty
129
+
|> Claude.Hooks.on_pre_tool_use ~pattern:"Bash" (fun input ->
130
+
if String.is_prefix ~prefix:"rm" (input.tool_input |> Claude.Tool_input.get_string "command" |> Option.value ~default:"") then
131
+
Claude.Hooks.PreToolUse.deny ~reason:"Dangerous command" ()
132
+
else
133
+
Claude.Hooks.PreToolUse.continue ())
103
134
104
-
(* Enable info logging for transport layer *)
105
-
Logs.Src.set_level Transport.src (Some Logs.Info)
135
+
let options =
136
+
Claude.Options.default |> Claude.Options.with_hooks hooks
106
137
]}
107
138
108
139
{1 Error Handling}
109
140
110
-
The library uses exceptions for error handling. Common exceptions include:
111
-
- [Invalid_argument]: For malformed JSON or invalid parameters
112
-
- [Transport.Transport_error]: For CLI communication failures
113
-
- [Message.Message_parse_error]: For message parsing failures
141
+
The library uses a structured exception type {!Err.E} for all errors:
142
+
143
+
{[
144
+
try
145
+
Claude.Client.query client "Hello"
146
+
with Claude.Err.E err ->
147
+
Printf.eprintf "Error: %s\n" (Claude.Err.to_string err)
148
+
]}
114
149
115
-
{1 Example: Complete Session}
150
+
Error types include:
151
+
- {!Err.Cli_not_found}: Claude CLI not found
152
+
- {!Err.Process_error}: Process execution failure
153
+
- {!Err.Protocol_error}: JSON/protocol parsing error
154
+
- {!Err.Timeout}: Operation timed out
155
+
- {!Err.Permission_denied}: Tool permission denied
156
+
- {!Err.Hook_error}: Hook callback error
116
157
117
-
{[
118
-
let run_claude_session ~sw env =
119
-
let options =
120
-
Options.create ~allowed_tools:[ "Read"; "Write" ]
121
-
~permission_mode:Permissions.Mode.Accept_edits
122
-
~system_prompt:"You are an OCaml expert." ~max_thinking_tokens:10000
123
-
()
124
-
in
158
+
{1 Logging}
125
159
126
-
let prompt = "Write a function to calculate fibonacci numbers" in
127
-
let messages = Client.query ~sw env ~options prompt in
160
+
The library uses the Logs library for structured logging. Each module has
161
+
its own log source allowing fine-grained control:
128
162
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
163
+
{[
164
+
Logs.Src.set_level Claude.Client.src (Some Logs.Debug);
165
+
Logs.Src.set_level Claude.Transport.src (Some Logs.Info)
149
166
]} *)
150
167
151
-
(** {1 Modules} *)
168
+
(** {1 Core Modules} *)
169
+
170
+
module Err = Err
171
+
(** Error handling with structured exception type. *)
152
172
153
173
module Client = Client
154
174
(** High-level client interface for Claude interactions. *)
···
156
176
module Options = Options
157
177
(** Configuration options for Claude sessions. *)
158
178
159
-
module Model = Model
160
-
(** Claude AI model identifiers with type-safe variants. *)
179
+
module Response = Response
180
+
(** High-level response events from Claude. *)
181
+
182
+
module Handler = Handler
183
+
(** Object-oriented response handler with sensible defaults. *)
184
+
185
+
(** {1 Domain Types} *)
186
+
187
+
module Tool_input = Tool_input
188
+
(** Opaque tool input with typed accessors. *)
161
189
162
190
module Content_block = Content_block
163
191
(** Content blocks for messages (text, tool use, tool results, thinking). *)
···
165
193
module Message = Message
166
194
(** Messages exchanged with Claude (user, assistant, system, result). *)
167
195
168
-
module Control = Control
169
-
(** Control messages for session management. *)
170
-
171
196
module Permissions = Permissions
172
197
(** Permission system for tool invocations. *)
173
198
174
199
module Hooks = Hooks
175
-
(** Hooks system for event interception. *)
200
+
(** Fully typed hook callbacks for event interception. *)
176
201
177
-
module Sdk_control = Sdk_control
178
-
(** SDK control protocol for dynamic configuration. *)
202
+
module Server_info = Server_info
203
+
(** Server capabilities and metadata. *)
179
204
180
-
module Incoming = Incoming
181
-
(** Discriminated union of all incoming message types from Claude CLI. *)
205
+
module Model = Model
206
+
(** Claude AI model identifiers. *)
182
207
183
-
module Structured_output = Structured_output
184
-
(** Structured output support using JSON Schema. *)
208
+
(** {1 Infrastructure} *)
185
209
186
210
module Transport = Transport
187
211
(** Low-level transport layer for CLI communication. *)
212
+
213
+
(** {1 Wire Format (Advanced)}
214
+
215
+
The {!Proto} module provides direct access to wire-format types and JSON
216
+
codecs. Use this for advanced scenarios like custom transports or debugging.
217
+
218
+
Most users should use the high-level types above instead. *)
219
+
220
+
module Proto = Proto
221
+
(** Wire-format types and JSON codecs. *)
+142
-118
lib/client.ml
+142
-118
lib/client.ml
···
23
23
|> Result.map_error Jsont.Error.to_string
24
24
|> Err.get_ok ~msg:""
25
25
26
-
(** Wire-level codec for permission responses to CLI. Uses camelCase field names
27
-
as expected by the CLI protocol. *)
28
-
module Permission_wire = struct
29
-
type allow = { allow_behavior : string; allow_updated_input : Jsont.json }
30
-
type deny = { deny_behavior : string; deny_message : string }
31
-
32
-
let allow_jsont : allow Jsont.t =
33
-
let make allow_behavior allow_updated_input =
34
-
{ allow_behavior; allow_updated_input }
35
-
in
36
-
Jsont.Object.map ~kind:"AllowWire" make
37
-
|> Jsont.Object.mem "behavior" Jsont.string ~enc:(fun r -> r.allow_behavior)
38
-
|> Jsont.Object.mem "updatedInput" Jsont.json ~enc:(fun r ->
39
-
r.allow_updated_input)
40
-
|> Jsont.Object.finish
41
-
42
-
let deny_jsont : deny Jsont.t =
43
-
let make deny_behavior deny_message = { deny_behavior; deny_message } in
44
-
Jsont.Object.map ~kind:"DenyWire" make
45
-
|> Jsont.Object.mem "behavior" Jsont.string ~enc:(fun r -> r.deny_behavior)
46
-
|> Jsont.Object.mem "message" Jsont.string ~enc:(fun r -> r.deny_message)
47
-
|> Jsont.Object.finish
48
-
49
-
let encode_allow ~updated_input =
50
-
Jsont.Json.encode allow_jsont
51
-
{ allow_behavior = "allow"; allow_updated_input = updated_input }
52
-
|> Err.get_ok ~msg:"Permission_wire.encode_allow: "
53
-
54
-
let encode_deny ~message =
55
-
Jsont.Json.encode deny_jsont
56
-
{ deny_behavior = "deny"; deny_message = message }
57
-
|> Err.get_ok ~msg:"Permission_wire.encode_deny: "
58
-
end
59
-
60
26
(** Wire-level codec for hook matcher configuration sent to CLI. *)
61
27
module Hook_matcher_wire = struct
62
28
type t = { matcher : string option; hook_callback_ids : string list }
···
80
46
81
47
type t = {
82
48
transport : Transport.t;
83
-
permission_callback : Permissions.callback option;
84
-
permission_log : Permissions.Rule.t list ref option;
85
-
hook_callbacks : (string, Hooks.callback) Hashtbl.t;
49
+
mutable permission_callback : Permissions.callback option;
50
+
mutable permission_log : Permissions.Rule.t list ref option;
51
+
hook_callbacks : (string, Jsont.json -> Proto.Hooks.result) Hashtbl.t;
86
52
mutable session_id : string option;
87
53
control_responses : (string, Jsont.json) Hashtbl.t;
88
54
control_mutex : Eio.Mutex.t;
···
98
64
match ctrl_req.request with
99
65
| Sdk_control.Request.Permission req ->
100
66
let tool_name = req.tool_name in
101
-
let input = req.input in
67
+
let input_json = req.input in
102
68
Log.info (fun m ->
103
69
m "Permission request for tool '%s' with input: %s" tool_name
104
-
(json_to_string input));
105
-
(* Convert permission_suggestions to Context *)
70
+
(json_to_string input_json));
71
+
(* Convert permission_suggestions to suggested rules *)
106
72
let suggestions = Option.value req.permission_suggestions ~default:[] in
107
-
let context = Permissions.Context.create ~suggestions () in
73
+
let suggested_rules = Permissions.extract_rules_from_proto_updates suggestions in
74
+
75
+
(* Convert input to Tool_input.t *)
76
+
let input = Tool_input.of_json input_json in
77
+
78
+
(* Create context *)
79
+
let context : Permissions.context =
80
+
{ tool_name; input; suggested_rules }
81
+
in
108
82
109
83
Log.info (fun m ->
110
84
m "Invoking permission callback for tool: %s" tool_name);
111
85
let callback =
112
86
Option.value t.permission_callback
113
-
~default:Permissions.default_allow_callback
87
+
~default:Permissions.default_allow
114
88
in
115
-
let result = callback ~tool_name ~input ~context in
89
+
let decision = callback context in
116
90
Log.info (fun m ->
117
91
m "Permission callback returned: %s"
118
-
(match result with
119
-
| Permissions.Result.Allow _ -> "ALLOW"
120
-
| Permissions.Result.Deny _ -> "DENY"));
92
+
(if Permissions.Decision.is_allow decision then "ALLOW" else "DENY"));
121
93
122
-
(* Convert permission result to CLI format using wire codec *)
94
+
(* Convert permission decision to proto result *)
95
+
let proto_result = Permissions.Decision.to_proto_result decision in
96
+
97
+
(* Encode to JSON *)
123
98
let response_data =
124
-
match result with
125
-
| Permissions.Result.Allow
126
-
{ updated_input; updated_permissions = _; unknown = _ } ->
127
-
let updated_input = Option.value updated_input ~default:input in
128
-
Permission_wire.encode_allow ~updated_input
129
-
| Permissions.Result.Deny { message; interrupt = _; unknown = _ } ->
130
-
Permission_wire.encode_deny ~message
99
+
match Jsont.Json.encode Proto.Permissions.Result.jsont proto_result with
100
+
| Ok json -> json
101
+
| Error err ->
102
+
Log.err (fun m -> m "Failed to encode permission result: %s" err);
103
+
failwith "Permission result encoding failed"
131
104
in
132
105
let response =
133
106
Control_response.success ~request_id ~response:(Some response_data)
···
138
111
| Sdk_control.Request.Hook_callback req -> (
139
112
let callback_id = req.callback_id in
140
113
let input = req.input in
141
-
let tool_use_id = req.tool_use_id in
114
+
let _tool_use_id = req.tool_use_id in
142
115
Log.info (fun m ->
143
116
m "Hook callback request for callback_id: %s" callback_id);
144
117
145
118
try
146
119
let callback = Hashtbl.find t.hook_callbacks callback_id in
147
-
let context = Hooks.Context.create () in
148
-
let result = callback ~input ~tool_use_id ~context in
120
+
let result = callback input in
149
121
150
122
let result_json =
151
-
Jsont.Json.encode Hooks.result_jsont result
123
+
Jsont.Json.encode Proto.Hooks.result_jsont result
152
124
|> Err.get_ok ~msg:"Failed to encode hook result: "
153
125
in
154
126
Log.debug (fun m ->
···
197
169
Hashtbl.replace t.control_responses request_id json;
198
170
Eio.Condition.broadcast t.control_condition)
199
171
200
-
let handle_messages t =
172
+
let handle_raw_messages t =
201
173
let rec loop () =
202
174
match Transport.receive_line t.transport with
203
175
| None ->
···
207
179
| Some line -> (
208
180
(* Use unified Incoming codec for all message types *)
209
181
match Jsont_bytesrw.decode_string' Incoming.jsont line with
210
-
| Ok (Incoming.Message msg) ->
182
+
| Ok incoming ->
183
+
Seq.Cons (incoming, loop)
184
+
| Error err ->
185
+
Log.err (fun m ->
186
+
m "Failed to decode incoming message: %s\nLine: %s"
187
+
(Jsont.Error.to_string err)
188
+
line);
189
+
loop ())
190
+
in
191
+
Log.debug (fun m -> m "Starting message handler");
192
+
loop
193
+
194
+
let handle_messages t =
195
+
let raw_seq = handle_raw_messages t in
196
+
let rec loop raw_seq =
197
+
match raw_seq () with
198
+
| Seq.Nil -> Seq.Nil
199
+
| Seq.Cons (incoming, rest) -> (
200
+
match incoming with
201
+
| Incoming.Message msg ->
211
202
Log.info (fun m -> m "ā %a" Message.pp msg);
212
203
213
204
(* Extract session ID from system messages *)
···
219
210
Log.debug (fun m -> m "Stored session ID: %s" session_id))
220
211
| _ -> ());
221
212
222
-
Seq.Cons (msg, loop)
223
-
| Ok (Incoming.Control_response resp) ->
213
+
(* Convert message to response events *)
214
+
let responses = Response.of_message msg in
215
+
emit_responses responses rest
216
+
| Incoming.Control_response resp ->
224
217
handle_control_response t resp;
225
-
loop ()
226
-
| Ok (Incoming.Control_request ctrl_req) ->
218
+
loop rest
219
+
| Incoming.Control_request ctrl_req ->
227
220
Log.info (fun m ->
228
221
m "Received control request (request_id: %s)"
229
222
ctrl_req.request_id);
230
223
handle_control_request t ctrl_req;
231
-
loop ()
232
-
| Error err ->
233
-
Log.err (fun m ->
234
-
m "Failed to decode incoming message: %s\nLine: %s"
235
-
(Jsont.Error.to_string err)
236
-
line);
237
-
loop ())
224
+
loop rest)
225
+
226
+
and emit_responses responses rest =
227
+
match responses with
228
+
| [] -> loop rest
229
+
| r :: rs -> Seq.Cons (r, fun () -> emit_responses rs rest)
238
230
in
239
-
Log.debug (fun m -> m "Starting message handler");
240
-
loop
231
+
loop raw_seq
241
232
242
233
let create ?(options = Options.default) ~sw ~process_mgr () =
243
234
(* Automatically enable permission prompt tool when callback is configured
···
273
264
|> Option.iter (fun hooks_config ->
274
265
Log.info (fun m -> m "Registering hooks...");
275
266
267
+
(* Get callbacks in wire format from the new Hooks API *)
268
+
let callbacks_by_event = Hooks.get_callbacks hooks_config in
269
+
276
270
(* Build hooks configuration with callback IDs as (string * Jsont.json) list *)
277
271
let hooks_list =
278
272
List.map
279
273
(fun (event, matchers) ->
280
-
let event_name = Hooks.event_to_string event in
274
+
let event_name = Proto.Hooks.event_to_string event in
281
275
let matcher_wires =
282
276
List.map
283
-
(fun matcher ->
284
-
let callback_ids =
285
-
List.map
286
-
(fun callback ->
287
-
let callback_id =
288
-
Printf.sprintf "hook_%d" !next_callback_id
289
-
in
290
-
incr next_callback_id;
291
-
Hashtbl.add hook_callbacks callback_id callback;
292
-
Log.debug (fun m ->
293
-
m "Registered callback: %s for event: %s"
294
-
callback_id event_name);
295
-
callback_id)
296
-
matcher.Hooks.callbacks
277
+
(fun (pattern, callback) ->
278
+
let callback_id =
279
+
Printf.sprintf "hook_%d" !next_callback_id
297
280
in
281
+
incr next_callback_id;
282
+
Hashtbl.add hook_callbacks callback_id callback;
283
+
Log.debug (fun m ->
284
+
m "Registered callback: %s for event: %s"
285
+
callback_id event_name);
298
286
Hook_matcher_wire.
299
287
{
300
-
matcher = matcher.Hooks.matcher;
301
-
hook_callback_ids = callback_ids;
288
+
matcher = pattern;
289
+
hook_callback_ids = [callback_id];
302
290
})
303
291
matchers
304
292
in
305
293
(event_name, Hook_matcher_wire.encode matcher_wires))
306
-
hooks_config
294
+
callbacks_by_event
307
295
in
308
296
309
297
(* Create initialize request using Sdk_control codec *)
···
320
308
321
309
t
322
310
323
-
let query t prompt =
324
-
let msg = Message.user_string prompt in
325
-
Log.info (fun m -> m "ā %a" Message.pp msg);
326
-
let json = Message.to_json msg in
327
-
Transport.send t.transport json
328
-
311
+
(* Helper to send a message with proper "type" wrapper via Proto.Outgoing *)
329
312
let send_message t msg =
330
313
Log.info (fun m -> m "ā %a" Message.pp msg);
331
-
let json = Message.to_json msg in
314
+
let proto_msg = Message.to_proto msg in
315
+
let outgoing = Proto.Outgoing.Message proto_msg in
316
+
let json = Proto.Outgoing.to_json outgoing in
332
317
Transport.send t.transport json
333
318
334
-
let send_user_message t user_msg =
319
+
let query t prompt =
320
+
let msg = Message.user_string prompt in
321
+
send_message t msg
322
+
323
+
let respond_to_tool t ~tool_use_id ~content ?(is_error = false) () =
324
+
let user_msg = Message.User.with_tool_result ~tool_use_id ~content ~is_error () in
335
325
let msg = Message.User user_msg in
336
-
Log.info (fun m -> m "ā %a" Message.pp msg);
337
-
let json = Message.User.to_json user_msg in
338
-
Transport.send t.transport json
326
+
send_message t msg
339
327
340
-
let receive t = handle_messages t
328
+
let respond_to_tools t responses =
329
+
let tool_results =
330
+
List.map
331
+
(fun (tool_use_id, content, is_error_opt) ->
332
+
let is_error = Option.value is_error_opt ~default:false in
333
+
Content_block.tool_result ~tool_use_id ~content ~is_error ())
334
+
responses
335
+
in
336
+
let user_msg = Message.User.of_blocks tool_results in
337
+
let msg = Message.User user_msg in
338
+
send_message t msg
339
+
340
+
let receive t = fun () -> handle_messages t
341
+
342
+
let run t ~handler =
343
+
Seq.iter (Handler.dispatch handler) (receive t)
341
344
342
345
let receive_all t =
343
346
let rec collect acc seq =
344
347
match seq () with
345
348
| Seq.Nil ->
346
349
Log.debug (fun m ->
347
-
m "End of message sequence (%d messages)" (List.length acc));
350
+
m "End of response sequence (%d responses)" (List.length acc));
348
351
List.rev acc
349
-
| Seq.Cons ((Message.Result _ as msg), _) ->
350
-
Log.debug (fun m -> m "Received final Result message");
351
-
List.rev (msg :: acc)
352
-
| Seq.Cons (msg, rest) -> collect (msg :: acc) rest
352
+
| Seq.Cons ((Response.Complete _ as resp), _) ->
353
+
Log.debug (fun m -> m "Received final Complete response");
354
+
List.rev (resp :: acc)
355
+
| Seq.Cons (resp, rest) -> collect (resp :: acc) rest
353
356
in
354
-
collect [] (handle_messages t)
357
+
collect [] (receive t)
355
358
356
359
let interrupt t = Transport.interrupt t.transport
357
360
358
-
let discover_permissions t =
361
+
let enable_permission_discovery t =
359
362
let log = ref [] in
360
-
let callback = Permissions.discovery_callback log in
361
-
{ t with permission_callback = Some callback; permission_log = Some log }
363
+
let callback = Permissions.discovery log in
364
+
t.permission_callback <- Some callback;
365
+
t.permission_log <- Some log
362
366
363
-
let get_discovered_permissions t =
367
+
let discovered_permissions t =
364
368
t.permission_log |> Option.map ( ! ) |> Option.value ~default:[]
365
-
366
-
let with_permission_callback t callback =
367
-
{ t with permission_callback = Some callback }
368
369
369
370
(* Helper to send a control request and wait for response *)
370
371
let send_control_request t ~request_id request =
···
427
428
428
429
let set_permission_mode t mode =
429
430
let request_id = Printf.sprintf "set_perm_mode_%f" (Unix.gettimeofday ()) in
430
-
let request = Sdk_control.Request.set_permission_mode ~mode () in
431
+
let proto_mode = Permissions.Mode.to_proto mode in
432
+
let request = Sdk_control.Request.set_permission_mode ~mode:proto_mode () in
431
433
let _response = send_control_request t ~request_id request in
432
434
Log.info (fun m ->
433
435
m "Permission mode set to: %s" (Permissions.Mode.to_string mode))
···
455
457
m "Retrieved server info: %a"
456
458
(Jsont.pp_value Sdk_control.Server_info.jsont ())
457
459
server_info);
458
-
server_info
460
+
Server_info.of_sdk_control server_info
461
+
462
+
module Advanced = struct
463
+
let send_message t msg = send_message t msg
464
+
465
+
let send_user_message t user_msg =
466
+
let msg = Message.User user_msg in
467
+
send_message t msg
468
+
469
+
let send_raw t control =
470
+
let json =
471
+
Jsont.Json.encode Sdk_control.jsont control
472
+
|> Err.get_ok ~msg:"Failed to encode control message: "
473
+
in
474
+
Log.info (fun m -> m "ā Raw control: %s" (json_to_string json));
475
+
Transport.send t.transport json
476
+
477
+
let send_json t json =
478
+
Log.info (fun m -> m "ā Raw JSON: %s" (json_to_string json));
479
+
Transport.send t.transport json
480
+
481
+
let receive_raw t = handle_raw_messages t
482
+
end
+115
-38
lib/client.mli
+115
-38
lib/client.mli
···
64
64
@param sw Eio switch for resource management
65
65
@param process_mgr Eio process manager for spawning the Claude CLI *)
66
66
67
+
(** {1 Simple Query Interface} *)
68
+
67
69
val query : t -> string -> unit
68
70
(** [query t prompt] sends a text message to Claude.
69
71
70
72
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. *)
73
+
messages with tool results or multiple content blocks, use
74
+
{!Advanced.send_message} instead. *)
73
75
74
-
val send_message : t -> Message.t -> unit
75
-
(** [send_message t msg] sends a message to Claude.
76
+
val respond_to_tool :
77
+
t -> tool_use_id:string -> content:string -> ?is_error:bool -> unit -> unit
78
+
(** [respond_to_tool t ~tool_use_id ~content ?is_error ()] responds to a tool
79
+
use request.
76
80
77
-
Supports all message types including user messages with tool results. *)
81
+
@param tool_use_id The ID from the {!Response.Tool_use.t} event
82
+
@param content The result content (can be any string)
83
+
@param is_error Whether this is an error response (default: false) *)
84
+
85
+
val respond_to_tools : t -> (string * string * bool option) list -> unit
86
+
(** [respond_to_tools t responses] responds to multiple tool use requests at
87
+
once.
78
88
79
-
val send_user_message : t -> Message.User.t -> unit
80
-
(** [send_user_message t msg] sends a user message to Claude. *)
89
+
Each tuple is [(tool_use_id, content, is_error option)].
81
90
82
-
val receive : t -> Message.t Seq.t
83
-
(** [receive t] returns a lazy sequence of messages from Claude.
91
+
Example:
92
+
{[
93
+
Client.respond_to_tools client
94
+
[
95
+
("tool_use_123", "Success", None);
96
+
("tool_use_456", "Error occurred", Some true);
97
+
]
98
+
]} *)
84
99
85
-
The sequence yields messages as they arrive from Claude, including:
86
-
- {!constructor:Message.Assistant} - Claude's responses
87
-
- {!constructor:Message.System} - System notifications
88
-
- {!constructor:Message.Result} - Final result with usage statistics
100
+
(** {1 Response Handling} *)
89
101
90
-
Control messages (permission requests, hook callbacks) are handled
91
-
internally and not yielded to the sequence. *)
102
+
val run : t -> handler:#Handler.handler -> unit
103
+
(** [run t ~handler] processes all responses using the given handler.
92
104
93
-
val receive_all : t -> Message.t list
94
-
(** [receive_all t] collects all messages into a list.
105
+
This is the recommended way to handle responses in an event-driven style.
106
+
The handler's methods will be called for each response event as it arrives.
95
107
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. *)
108
+
Example:
109
+
{[
110
+
let my_handler = object
111
+
inherit Claude.Handler.default
112
+
method! on_text t = print_endline (Response.Text.content t)
113
+
method! on_complete c =
114
+
Printf.printf "Cost: $%.4f\n"
115
+
(Option.value ~default:0.0 (Response.Complete.total_cost_usd c))
116
+
end in
117
+
Client.query client "Hello";
118
+
Client.run client ~handler:my_handler
119
+
]} *)
99
120
100
-
val interrupt : t -> unit
101
-
(** [interrupt t] sends an interrupt signal to stop Claude's execution. *)
121
+
val receive : t -> Response.t Seq.t
122
+
(** [receive t] returns a lazy sequence of responses from Claude.
102
123
103
-
val discover_permissions : t -> t
104
-
(** [discover_permissions t] enables permission discovery mode.
124
+
The sequence yields response events as they arrive from Claude, including:
125
+
- {!constructor:Response.Text} - Text content from assistant
126
+
- {!constructor:Response.Tool_use} - Tool invocation requests
127
+
- {!constructor:Response.Thinking} - Internal reasoning
128
+
- {!constructor:Response.Init} - Session initialization
129
+
- {!constructor:Response.Error} - Error events
130
+
- {!constructor:Response.Complete} - Final result with usage statistics
105
131
106
-
In discovery mode, all tool usage is logged but allowed. Use
107
-
{!get_discovered_permissions} to retrieve the list of permissions that were
108
-
requested during execution.
132
+
Control messages (permission requests, hook callbacks) are handled
133
+
internally and not yielded to the sequence.
109
134
110
-
This is useful for understanding what permissions your prompt requires. *)
135
+
For simple cases, prefer {!run} with a handler instead. *)
111
136
112
-
val get_discovered_permissions : t -> Permissions.Rule.t list
113
-
(** [get_discovered_permissions t] returns permissions discovered during
114
-
execution.
137
+
val receive_all : t -> Response.t list
138
+
(** [receive_all t] collects all responses into a list.
115
139
116
-
Only useful after enabling {!discover_permissions}. *)
140
+
This is a convenience function that consumes the {!receive} sequence. Use
141
+
this when you want to process all responses at once rather than streaming
142
+
them.
117
143
118
-
val with_permission_callback : t -> Permissions.callback -> t
119
-
(** [with_permission_callback t callback] updates the permission callback.
144
+
For most cases, prefer {!run} with a handler instead. *)
120
145
121
-
Allows dynamically changing the permission callback without recreating the
122
-
client. *)
146
+
val interrupt : t -> unit
147
+
(** [interrupt t] sends an interrupt signal to stop Claude's execution. *)
123
148
124
-
(** {1 Dynamic Control Methods}
149
+
(** {1 Dynamic Control}
125
150
126
151
These methods allow you to change Claude's behavior mid-conversation without
127
152
recreating the client. This is useful for:
···
200
225
201
226
@raise Failure if the model is invalid or unavailable *)
202
227
203
-
val get_server_info : t -> Sdk_control.Server_info.t
228
+
val get_server_info : t -> Server_info.t
204
229
(** [get_server_info t] retrieves server capabilities and metadata.
205
230
206
231
Returns information about:
···
212
237
Useful for feature detection and debugging.
213
238
214
239
@raise Failure if the server returns an error *)
240
+
241
+
(** {1 Permission Discovery} *)
242
+
243
+
val enable_permission_discovery : t -> unit
244
+
(** [enable_permission_discovery t] enables permission discovery mode.
245
+
246
+
In discovery mode, all tool usage is logged but allowed. Use
247
+
{!discovered_permissions} to retrieve the list of permissions that were
248
+
requested during execution.
249
+
250
+
This is useful for understanding what permissions your prompt requires. *)
251
+
252
+
val discovered_permissions : t -> Permissions.Rule.t list
253
+
(** [discovered_permissions t] returns permissions discovered during execution.
254
+
255
+
Only useful after enabling {!enable_permission_discovery}. *)
256
+
257
+
(** {1 Advanced Interface}
258
+
259
+
Low-level access to the protocol for advanced use cases. *)
260
+
261
+
module Advanced : sig
262
+
val send_message : t -> Message.t -> unit
263
+
(** [send_message t msg] sends a message to Claude.
264
+
265
+
Supports all message types including user messages with tool results. *)
266
+
267
+
val send_user_message : t -> Message.User.t -> unit
268
+
(** [send_user_message t msg] sends a user message to Claude. *)
269
+
270
+
val send_raw : t -> Sdk_control.t -> unit
271
+
(** [send_raw t control] sends a raw SDK control message.
272
+
273
+
This is for advanced use cases that need direct control protocol access. *)
274
+
275
+
val send_json : t -> Jsont.json -> unit
276
+
(** [send_json t json] sends raw JSON to Claude.
277
+
278
+
This is the lowest-level send operation. Use with caution. *)
279
+
280
+
val receive_raw : t -> Incoming.t Seq.t
281
+
(** [receive_raw t] returns a lazy sequence of raw incoming messages.
282
+
283
+
This includes all message types before Response conversion:
284
+
- {!Incoming.Message} - Regular messages
285
+
- {!Incoming.Control_response} - Control responses (normally handled
286
+
internally)
287
+
- {!Incoming.Control_request} - Control requests (normally handled
288
+
internally)
289
+
290
+
Most users should use {!receive} or {!run} instead. *)
291
+
end
+72
-141
lib/content_block.ml
+72
-141
lib/content_block.ml
···
3
3
module Log = (val Logs.src_log src : Logs.LOG)
4
4
5
5
module Text = struct
6
-
type t = { text : string; unknown : Unknown.t }
7
-
8
-
let create text = { text; unknown = Unknown.empty }
9
-
let make text unknown = { text; unknown }
10
-
let text t = t.text
11
-
let unknown t = t.unknown
6
+
type t = Proto.Content_block.Text.t
12
7
13
-
let jsont : t Jsont.t =
14
-
Jsont.Object.map ~kind:"Text" make
15
-
|> Jsont.Object.mem "text" Jsont.string ~enc:text
16
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
17
-
|> Jsont.Object.finish
8
+
let text = Proto.Content_block.Text.text
9
+
let of_proto proto = proto
10
+
let to_proto t = t
18
11
end
19
12
20
13
module Tool_use = struct
21
-
module Input = struct
22
-
(* Dynamic JSON data for tool inputs with typed accessors using jsont decoders *)
23
-
type t = Jsont.json
24
-
25
-
let jsont = Jsont.json
26
-
27
-
let of_string_pairs 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)
14
+
type t = Proto.Content_block.Tool_use.t
33
15
34
-
let of_assoc (assoc : (string * Jsont.json) list) : t =
35
-
Jsont.Json.object'
36
-
(List.map (fun (k, v) -> Jsont.Json.mem (Jsont.Json.name k) v) assoc)
16
+
let id = Proto.Content_block.Tool_use.id
17
+
let name = Proto.Content_block.Tool_use.name
37
18
38
-
(* Helper to decode an optional field with a given codec *)
39
-
let get_opt (type a) (codec : a Jsont.t) t key : a option =
40
-
let field_codec =
41
-
Jsont.Object.map ~kind:"field" (fun v -> v)
42
-
|> Jsont.Object.opt_mem key codec ~enc:Fun.id
43
-
|> Jsont.Object.finish
44
-
in
45
-
match Jsont.Json.decode field_codec t with Ok v -> v | Error _ -> None
19
+
let input t =
20
+
Proto.Content_block.Tool_use.input t |> Tool_input.of_json
46
21
47
-
let get_string t key = get_opt Jsont.string t key
48
-
let get_int t key = get_opt Jsont.int t key
49
-
let get_bool t key = get_opt Jsont.bool t key
50
-
let get_float t key = get_opt Jsont.number t key
22
+
let of_proto proto = proto
51
23
52
-
let keys t =
53
-
(* Decode as object with all members captured as unknown *)
54
-
match t with
55
-
| Jsont.Object (members, _) ->
56
-
List.map (fun ((name, _), _) -> name) members
57
-
| _ -> []
58
-
end
59
-
60
-
type t = { id : string; name : string; input : Input.t; unknown : Unknown.t }
61
-
62
-
let create ~id ~name ~input = { id; name; input; unknown = Unknown.empty }
63
-
let make id name input unknown = { id; name; input; unknown }
64
-
let id t = t.id
65
-
let name t = t.name
66
-
let input t = t.input
67
-
let unknown t = t.unknown
68
-
69
-
let jsont : t Jsont.t =
70
-
Jsont.Object.map ~kind:"Tool_use" make
71
-
|> Jsont.Object.mem "id" Jsont.string ~enc:id
72
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
73
-
|> Jsont.Object.mem "input" Input.jsont ~enc:input
74
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
75
-
|> Jsont.Object.finish
24
+
let to_proto t = t
76
25
end
77
26
78
27
module Tool_result = struct
79
-
type t = {
80
-
tool_use_id : string;
81
-
content : string option;
82
-
is_error : bool option;
83
-
unknown : Unknown.t;
84
-
}
28
+
type t = Proto.Content_block.Tool_result.t
85
29
86
-
let create ~tool_use_id ?content ?is_error () =
87
-
{ tool_use_id; content; is_error; unknown = Unknown.empty }
88
-
89
-
let make tool_use_id content is_error unknown =
90
-
{ tool_use_id; content; is_error; unknown }
91
-
92
-
let tool_use_id t = t.tool_use_id
93
-
let content t = t.content
94
-
let is_error t = t.is_error
95
-
let unknown t = t.unknown
96
-
97
-
let jsont : t Jsont.t =
98
-
Jsont.Object.map ~kind:"Tool_result" make
99
-
|> Jsont.Object.mem "tool_use_id" Jsont.string ~enc:tool_use_id
100
-
|> Jsont.Object.opt_mem "content" Jsont.string ~enc:content
101
-
|> Jsont.Object.opt_mem "is_error" Jsont.bool ~enc:is_error
102
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
103
-
|> Jsont.Object.finish
30
+
let tool_use_id = Proto.Content_block.Tool_result.tool_use_id
31
+
let content = Proto.Content_block.Tool_result.content
32
+
let is_error = Proto.Content_block.Tool_result.is_error
33
+
let of_proto proto = proto
34
+
let to_proto t = t
104
35
end
105
36
106
37
module Thinking = struct
107
-
type t = { thinking : string; signature : string; unknown : Unknown.t }
38
+
type t = Proto.Content_block.Thinking.t
108
39
109
-
let create ~thinking ~signature =
110
-
{ thinking; signature; unknown = Unknown.empty }
111
-
112
-
let make thinking signature unknown = { thinking; signature; unknown }
113
-
let thinking t = t.thinking
114
-
let signature t = t.signature
115
-
let unknown t = t.unknown
116
-
117
-
let jsont : t Jsont.t =
118
-
Jsont.Object.map ~kind:"Thinking" make
119
-
|> Jsont.Object.mem "thinking" Jsont.string ~enc:thinking
120
-
|> Jsont.Object.mem "signature" Jsont.string ~enc:signature
121
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
122
-
|> Jsont.Object.finish
40
+
let thinking = Proto.Content_block.Thinking.thinking
41
+
let signature = Proto.Content_block.Thinking.signature
42
+
let of_proto proto = proto
43
+
let to_proto t = t
123
44
end
124
45
125
46
type t =
···
128
49
| Tool_result of Tool_result.t
129
50
| Thinking of Thinking.t
130
51
131
-
let text s = Text (Text.create s)
132
-
let tool_use ~id ~name ~input = Tool_use (Tool_use.create ~id ~name ~input)
52
+
let text s =
53
+
let proto = Proto.Content_block.text s in
54
+
match proto with
55
+
| Proto.Content_block.Text proto_text -> Text (Text.of_proto proto_text)
56
+
| _ -> failwith "Internal error: Proto.Content_block.text returned non-Text"
57
+
58
+
let tool_use ~id ~name ~input =
59
+
let json_input = Tool_input.to_json input in
60
+
let proto = Proto.Content_block.tool_use ~id ~name ~input:json_input in
61
+
match proto with
62
+
| Proto.Content_block.Tool_use proto_tool_use ->
63
+
Tool_use (Tool_use.of_proto proto_tool_use)
64
+
| _ ->
65
+
failwith "Internal error: Proto.Content_block.tool_use returned non-Tool_use"
133
66
134
67
let tool_result ~tool_use_id ?content ?is_error () =
135
-
Tool_result (Tool_result.create ~tool_use_id ?content ?is_error ())
136
-
137
-
let thinking ~thinking ~signature =
138
-
Thinking (Thinking.create ~thinking ~signature)
139
-
140
-
let jsont : t Jsont.t =
141
-
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
142
-
143
-
let case_text = case_map "text" Text.jsont (fun v -> Text v) in
144
-
let case_tool_use =
145
-
case_map "tool_use" Tool_use.jsont (fun v -> Tool_use v)
68
+
let proto =
69
+
Proto.Content_block.tool_result ~tool_use_id ?content ?is_error ()
146
70
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
71
+
match proto with
72
+
| Proto.Content_block.Tool_result proto_tool_result ->
73
+
Tool_result (Tool_result.of_proto proto_tool_result)
74
+
| _ ->
75
+
failwith
76
+
"Internal error: Proto.Content_block.tool_result returned non-Tool_result"
153
77
154
-
let enc_case = function
155
-
| Text v -> Jsont.Object.Case.value case_text v
156
-
| Tool_use v -> Jsont.Object.Case.value case_tool_use v
157
-
| Tool_result v -> Jsont.Object.Case.value case_tool_result v
158
-
| Thinking v -> Jsont.Object.Case.value case_thinking v
159
-
in
78
+
let thinking ~thinking ~signature =
79
+
let proto = Proto.Content_block.thinking ~thinking ~signature in
80
+
match proto with
81
+
| Proto.Content_block.Thinking proto_thinking ->
82
+
Thinking (Thinking.of_proto proto_thinking)
83
+
| _ ->
84
+
failwith
85
+
"Internal error: Proto.Content_block.thinking returned non-Thinking"
160
86
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
87
+
let of_proto proto =
88
+
match proto with
89
+
| Proto.Content_block.Text t -> Text (Text.of_proto t)
90
+
| Proto.Content_block.Tool_use t -> Tool_use (Tool_use.of_proto t)
91
+
| Proto.Content_block.Tool_result t -> Tool_result (Tool_result.of_proto t)
92
+
| Proto.Content_block.Thinking t -> Thinking (Thinking.of_proto t)
170
93
171
-
Jsont.Object.map ~kind:"Content_block" Fun.id
172
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
173
-
~tag_to_string:Fun.id ~tag_compare:String.compare
174
-
|> Jsont.Object.finish
94
+
let to_proto = function
95
+
| Text t -> Proto.Content_block.Text (Text.to_proto t)
96
+
| Tool_use t -> Proto.Content_block.Tool_use (Tool_use.to_proto t)
97
+
| Tool_result t -> Proto.Content_block.Tool_result (Tool_result.to_proto t)
98
+
| Thinking t -> Proto.Content_block.Thinking (Thinking.to_proto t)
175
99
176
100
let log_received t =
101
+
let proto = to_proto t in
177
102
Log.debug (fun m ->
178
-
m "Received content block: %a" (Jsont.pp_value jsont ()) t)
103
+
m "Received content block: %a"
104
+
(Jsont.pp_value Proto.Content_block.jsont ())
105
+
proto)
179
106
180
107
let log_sending t =
181
-
Log.debug (fun m -> m "Sending content block: %a" (Jsont.pp_value jsont ()) t)
108
+
let proto = to_proto t in
109
+
Log.debug (fun m ->
110
+
m "Sending content block: %a"
111
+
(Jsont.pp_value Proto.Content_block.jsont ())
112
+
proto)
+43
-93
lib/content_block.mli
+43
-93
lib/content_block.mli
···
1
-
(** Content blocks for Claude messages.
1
+
(** Content blocks in messages. Opaque types without wire concerns.
2
2
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. *)
3
+
This module provides opaque wrapper types around the proto content block
4
+
types, hiding unknown fields and wire format details from the public API. *)
6
5
7
6
val src : Logs.Src.t
8
-
(** The log source for content block operations *)
7
+
(** Log source for content block operations. *)
9
8
10
9
(** {1 Text Blocks} *)
11
10
···
13
12
(** Plain text content blocks. *)
14
13
15
14
type t
16
-
(** The type of text blocks. *)
17
-
18
-
val create : string -> t
19
-
(** [create text] creates a new text block with the given text content. *)
15
+
(** The type of text blocks (opaque). *)
20
16
21
17
val text : t -> string
22
18
(** [text t] returns the text content of the block. *)
23
19
24
-
val unknown : t -> Unknown.t
25
-
(** [unknown t] returns any unknown fields from JSON parsing. *)
20
+
(** {1 Internal - for lib use only} *)
26
21
27
-
val jsont : t Jsont.t
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. *)
22
+
val of_proto : Proto.Content_block.Text.t -> t
23
+
(** [of_proto proto] wraps a proto text block. *)
24
+
25
+
val to_proto : t -> Proto.Content_block.Text.t
26
+
(** [to_proto t] extracts the proto text block. *)
31
27
end
32
28
33
29
(** {1 Tool Use Blocks} *)
···
35
31
module Tool_use : sig
36
32
(** Tool invocation requests from the assistant. *)
37
33
38
-
module Input : sig
39
-
(** Tool input parameters. *)
40
-
41
-
type t
42
-
(** Abstract type for tool inputs (opaque JSON). *)
43
-
44
-
val jsont : t Jsont.t
45
-
(** [jsont] is the Jsont codec for tool inputs. *)
46
-
47
-
val of_string_pairs : (string * string) list -> t
48
-
(** [of_string_pairs pairs] creates tool input from string key-value pairs.
49
-
*)
50
-
51
-
val of_assoc : (string * Jsont.json) list -> t
52
-
(** [of_assoc assoc] creates tool input from an association list. *)
53
-
54
-
val get_string : t -> string -> string option
55
-
(** [get_string t key] returns the string value for [key], if present. *)
56
-
57
-
val get_int : t -> string -> int option
58
-
(** [get_int t key] returns the integer value for [key], if present. *)
59
-
60
-
val get_bool : t -> string -> bool option
61
-
(** [get_bool t key] returns the boolean value for [key], if present. *)
62
-
63
-
val get_float : t -> string -> float option
64
-
(** [get_float t key] returns the float value for [key], if present. *)
65
-
66
-
val keys : t -> string list
67
-
(** [keys t] returns all keys in the input. *)
68
-
end
69
-
70
34
type t
71
-
(** The type of tool use blocks. *)
72
-
73
-
val create : id:string -> name:string -> input:Input.t -> t
74
-
(** [create ~id ~name ~input] creates a new tool use block.
75
-
@param id Unique identifier for this tool invocation
76
-
@param name Name of the tool to invoke
77
-
@param input Parameters for the tool *)
35
+
(** The type of tool use blocks (opaque). *)
78
36
79
37
val id : t -> string
80
38
(** [id t] returns the unique identifier of the tool use. *)
···
82
40
val name : t -> string
83
41
(** [name t] returns the name of the tool being invoked. *)
84
42
85
-
val input : t -> Input.t
43
+
val input : t -> Tool_input.t
86
44
(** [input t] returns the input parameters for the tool. *)
87
45
88
-
val unknown : t -> Unknown.t
89
-
(** [unknown t] returns any unknown fields from JSON parsing. *)
46
+
(** {1 Internal - for lib use only} *)
47
+
48
+
val of_proto : Proto.Content_block.Tool_use.t -> t
49
+
(** [of_proto proto] wraps a proto tool use block. *)
90
50
91
-
val jsont : t Jsont.t
92
-
(** [jsont] is the Jsont codec for tool use blocks. Use
93
-
[Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
94
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
51
+
val to_proto : t -> Proto.Content_block.Tool_use.t
52
+
(** [to_proto t] extracts the proto tool use block. *)
95
53
end
96
54
97
55
(** {1 Tool Result Blocks} *)
···
100
58
(** Results from tool invocations. *)
101
59
102
60
type t
103
-
(** The type of tool result blocks. *)
104
-
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.
109
-
@param tool_use_id The ID of the corresponding tool use block
110
-
@param content Optional result content
111
-
@param is_error Whether the tool execution resulted in an error *)
61
+
(** The type of tool result blocks (opaque). *)
112
62
113
63
val tool_use_id : t -> string
114
64
(** [tool_use_id t] returns the ID of the corresponding tool use. *)
···
119
69
val is_error : t -> bool option
120
70
(** [is_error t] returns whether this result represents an error. *)
121
71
122
-
val unknown : t -> Unknown.t
123
-
(** [unknown t] returns any unknown fields from JSON parsing. *)
72
+
(** {1 Internal - for lib use only} *)
73
+
74
+
val of_proto : Proto.Content_block.Tool_result.t -> t
75
+
(** [of_proto proto] wraps a proto tool result block. *)
124
76
125
-
val jsont : t Jsont.t
126
-
(** [jsont] is the Jsont codec for tool result blocks. Use
127
-
[Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
128
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
77
+
val to_proto : t -> Proto.Content_block.Tool_result.t
78
+
(** [to_proto t] extracts the proto tool result block. *)
129
79
end
130
80
131
81
(** {1 Thinking Blocks} *)
···
134
84
(** Assistant's internal reasoning blocks. *)
135
85
136
86
type t
137
-
(** The type of thinking blocks. *)
138
-
139
-
val create : thinking:string -> signature:string -> t
140
-
(** [create ~thinking ~signature] creates a new thinking block.
141
-
@param thinking The assistant's internal reasoning
142
-
@param signature Cryptographic signature for verification *)
87
+
(** The type of thinking blocks (opaque). *)
143
88
144
89
val thinking : t -> string
145
90
(** [thinking t] returns the thinking content. *)
···
147
92
val signature : t -> string
148
93
(** [signature t] returns the cryptographic signature. *)
149
94
150
-
val unknown : t -> Unknown.t
151
-
(** [unknown t] returns any unknown fields from JSON parsing. *)
95
+
(** {1 Internal - for lib use only} *)
96
+
97
+
val of_proto : Proto.Content_block.Thinking.t -> t
98
+
(** [of_proto proto] wraps a proto thinking block. *)
152
99
153
-
val jsont : t Jsont.t
154
-
(** [jsont] is the Jsont codec for thinking blocks. Use
155
-
[Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
156
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
100
+
val to_proto : t -> Proto.Content_block.Thinking.t
101
+
(** [to_proto t] extracts the proto thinking block. *)
157
102
end
158
103
159
104
(** {1 Content Block Union Type} *)
···
166
111
(** The type of content blocks, which can be text, tool use, tool result,
167
112
or thinking. *)
168
113
114
+
(** {1 Constructors} *)
115
+
169
116
val text : string -> t
170
117
(** [text s] creates a text content block. *)
171
118
172
-
val tool_use : id:string -> name:string -> input:Tool_use.Input.t -> t
119
+
val tool_use : id:string -> name:string -> input:Tool_input.t -> t
173
120
(** [tool_use ~id ~name ~input] creates a tool use content block. *)
174
121
175
122
val tool_result :
···
180
127
val thinking : thinking:string -> signature:string -> t
181
128
(** [thinking ~thinking ~signature] creates a thinking content block. *)
182
129
183
-
val jsont : t Jsont.t
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. *)
130
+
(** {1 Conversion} *)
131
+
132
+
val of_proto : Proto.Content_block.t -> t
133
+
(** [of_proto proto] converts a proto content block to a lib content block. *)
134
+
135
+
val to_proto : t -> Proto.Content_block.t
136
+
(** [to_proto t] converts a lib content block to a proto content block. *)
187
137
188
138
(** {1 Logging} *)
189
139
+1
-1
lib/dune
+1
-1
lib/dune
+49
-13
lib/err.ml
+49
-13
lib/err.ml
···
1
-
(** Error handling for the Claude protocol.
1
+
(** Error handling for claudeio. *)
2
2
3
-
This module provides a protocol-specific exception and Result combinators
4
-
for handling JSON encoding/decoding errors in the Claude SDK. *)
3
+
type t =
4
+
| Cli_not_found of string
5
+
| Process_error of string
6
+
| Connection_error of string
7
+
| Protocol_error of string
8
+
| Timeout of string
9
+
| Permission_denied of { tool_name : string; message : string }
10
+
| Hook_error of { callback_id : string; message : string }
11
+
| Control_error of { request_id : string; message : string }
5
12
6
-
exception Protocol_error of string
7
-
(** Raised when there is an error in the Claude protocol, such as JSON
8
-
encoding/decoding failures or malformed messages. *)
13
+
exception E of t
14
+
15
+
let pp ppf = function
16
+
| Cli_not_found msg -> Fmt.pf ppf "CLI not found: %s" msg
17
+
| Process_error msg -> Fmt.pf ppf "Process error: %s" msg
18
+
| Connection_error msg -> Fmt.pf ppf "Connection error: %s" msg
19
+
| Protocol_error msg -> Fmt.pf ppf "Protocol error: %s" msg
20
+
| Timeout msg -> Fmt.pf ppf "Timeout: %s" msg
21
+
| Permission_denied { tool_name; message } ->
22
+
Fmt.pf ppf "Permission denied for tool '%s': %s" tool_name message
23
+
| Hook_error { callback_id; message } ->
24
+
Fmt.pf ppf "Hook error (callback_id=%s): %s" callback_id message
25
+
| Control_error { request_id; message } ->
26
+
Fmt.pf ppf "Control error (request_id=%s): %s" request_id message
9
27
10
-
(** [protocol_error msg] raises [Protocol_error msg]. *)
28
+
let to_string err = Fmt.str "%a" pp err
29
+
30
+
let raise err = Stdlib.raise (E err)
31
+
32
+
(* Register exception printer for better error messages *)
33
+
let () =
34
+
Printexc.register_printer (function
35
+
| E err -> Some (to_string err)
36
+
| _ -> None)
37
+
38
+
(** {1 Convenience Raisers} *)
39
+
40
+
let cli_not_found msg = raise (Cli_not_found msg)
41
+
let process_error msg = raise (Process_error msg)
42
+
let connection_error msg = raise (Connection_error msg)
11
43
let protocol_error msg = raise (Protocol_error msg)
44
+
let timeout msg = raise (Timeout msg)
12
45
13
-
(** [get_ok ~msg r] returns [x] if [r] is [Ok x], or raises
14
-
[Protocol_error (msg ^ e)] if [r] is [Error e]. *)
46
+
let permission_denied ~tool_name ~message =
47
+
raise (Permission_denied { tool_name; message })
48
+
49
+
let hook_error ~callback_id ~message = raise (Hook_error { callback_id; message })
50
+
let control_error ~request_id ~message = raise (Control_error { request_id; message })
51
+
52
+
(** {1 Result Helpers} *)
53
+
15
54
let get_ok ~msg = function
16
55
| Ok x -> x
17
56
| Error e -> raise (Protocol_error (msg ^ e))
18
57
19
-
(** [get_ok' ~msg r] returns [x] if [r] is [Ok x], or raises
20
-
[Invalid_argument (msg ^ e)] if [r] is [Error e]. Use this for user-facing
21
-
parse errors where Invalid_argument is expected. *)
22
58
let get_ok' ~msg = function
23
59
| Ok x -> x
24
-
| Error e -> raise (Invalid_argument (msg ^ e))
60
+
| Error e -> raise (Protocol_error (msg ^ e))
+33
-12
lib/err.mli
+33
-12
lib/err.mli
···
1
-
(** Error handling for the Claude protocol.
1
+
(** Error handling for claudeio. *)
2
+
3
+
type t =
4
+
| Cli_not_found of string
5
+
| Process_error of string
6
+
| Connection_error of string
7
+
| Protocol_error of string
8
+
| Timeout of string
9
+
| Permission_denied of { tool_name : string; message : string }
10
+
| Hook_error of { callback_id : string; message : string }
11
+
| Control_error of { request_id : string; message : string }
12
+
13
+
exception E of t
14
+
15
+
val pp : Format.formatter -> t -> unit
16
+
(** Pretty-print an error. *)
17
+
18
+
val to_string : t -> string
19
+
(** Convert error to string. *)
2
20
3
-
This module provides a protocol-specific exception and Result combinators
4
-
for handling JSON encoding/decoding errors in the Claude SDK. *)
21
+
val raise : t -> 'a
22
+
(** [raise err] raises [E err]. *)
5
23
6
-
exception Protocol_error of string
7
-
(** Raised when there is an error in the Claude protocol, such as JSON
8
-
encoding/decoding failures or malformed messages. *)
24
+
(** {1 Convenience Raisers} *)
9
25
26
+
val cli_not_found : string -> 'a
27
+
val process_error : string -> 'a
28
+
val connection_error : string -> 'a
10
29
val protocol_error : string -> 'a
11
-
(** [protocol_error msg] raises [Protocol_error msg]. *)
30
+
val timeout : string -> 'a
31
+
val permission_denied : tool_name:string -> message:string -> 'a
32
+
val hook_error : callback_id:string -> message:string -> 'a
33
+
val control_error : request_id:string -> message:string -> 'a
34
+
35
+
(** {1 Result Helpers} *)
12
36
13
37
val get_ok : msg:string -> ('a, string) result -> 'a
14
-
(** [get_ok ~msg r] returns [x] if [r] is [Ok x], or raises
15
-
[Protocol_error (msg ^ e)] if [r] is [Error e]. *)
38
+
(** [get_ok ~msg result] returns the Ok value or raises Protocol_error with msg prefix. *)
16
39
17
40
val get_ok' : msg:string -> ('a, string) result -> 'a
18
-
(** [get_ok' ~msg r] returns [x] if [r] is [Ok x], or raises
19
-
[Invalid_argument (msg ^ e)] if [r] is [Error e]. Use this for user-facing
20
-
parse errors where Invalid_argument is expected. *)
41
+
(** [get_ok' ~msg result] returns the Ok value or raises Protocol_error with string error. *)
+53
lib/handler.ml
+53
lib/handler.ml
···
1
+
(** Object-oriented response handler implementations. *)
2
+
3
+
(** {1 Handler Interface} *)
4
+
5
+
class type handler =
6
+
object
7
+
method on_text : Response.Text.t -> unit
8
+
method on_tool_use : Response.Tool_use.t -> unit
9
+
method on_tool_result : Content_block.Tool_result.t -> unit
10
+
method on_thinking : Response.Thinking.t -> unit
11
+
method on_init : Response.Init.t -> unit
12
+
method on_error : Response.Error.t -> unit
13
+
method on_complete : Response.Complete.t -> unit
14
+
end
15
+
16
+
(** {1 Concrete Implementations} *)
17
+
18
+
class default : handler =
19
+
object
20
+
method on_text (_ : Response.Text.t) = ()
21
+
method on_tool_use (_ : Response.Tool_use.t) = ()
22
+
method on_tool_result (_ : Content_block.Tool_result.t) = ()
23
+
method on_thinking (_ : Response.Thinking.t) = ()
24
+
method on_init (_ : Response.Init.t) = ()
25
+
method on_error (_ : Response.Error.t) = ()
26
+
method on_complete (_ : Response.Complete.t) = ()
27
+
end
28
+
29
+
class virtual abstract =
30
+
object
31
+
method virtual on_text : Response.Text.t -> unit
32
+
method virtual on_tool_use : Response.Tool_use.t -> unit
33
+
method virtual on_tool_result : Content_block.Tool_result.t -> unit
34
+
method virtual on_thinking : Response.Thinking.t -> unit
35
+
method virtual on_init : Response.Init.t -> unit
36
+
method virtual on_error : Response.Error.t -> unit
37
+
method virtual on_complete : Response.Complete.t -> unit
38
+
end
39
+
40
+
(** {1 Dispatch Functions} *)
41
+
42
+
let dispatch (handler : #handler) (response : Response.t) =
43
+
match response with
44
+
| Response.Text t -> handler#on_text t
45
+
| Response.Tool_use t -> handler#on_tool_use t
46
+
| Response.Tool_result t -> handler#on_tool_result t
47
+
| Response.Thinking t -> handler#on_thinking t
48
+
| Response.Init t -> handler#on_init t
49
+
| Response.Error t -> handler#on_error t
50
+
| Response.Complete t -> handler#on_complete t
51
+
52
+
let dispatch_all (handler : #handler) (responses : Response.t list) =
53
+
List.iter (dispatch handler) responses
+159
lib/handler.mli
+159
lib/handler.mli
···
1
+
(** Object-oriented response handler with sensible defaults.
2
+
3
+
This module provides an object-oriented interface for handling response
4
+
events from Claude. It offers both a concrete default implementation (where
5
+
all methods do nothing) and an abstract base class (where all methods must
6
+
be implemented).
7
+
8
+
{1 Usage}
9
+
10
+
The simplest approach is to inherit from {!default} and override only the
11
+
methods you care about:
12
+
13
+
{[
14
+
let my_handler = object
15
+
inherit Claude.Handler.default
16
+
method! on_text t = print_endline (Response.Text.content t)
17
+
method! on_complete c =
18
+
Printf.printf "Done! Cost: $%.4f\n"
19
+
(Option.value ~default:0.0 (Response.Complete.total_cost_usd c))
20
+
end
21
+
]}
22
+
23
+
For compile-time guarantees that all events are handled, inherit from
24
+
{!abstract}:
25
+
26
+
{[
27
+
let complete_handler = object
28
+
inherit Claude.Handler.abstract
29
+
method on_text t = (* must implement *)
30
+
method on_tool_use t = (* must implement *)
31
+
method on_tool_result t = (* must implement *)
32
+
method on_thinking t = (* must implement *)
33
+
method on_init t = (* must implement *)
34
+
method on_error t = (* must implement *)
35
+
method on_complete t = (* must implement *)
36
+
end
37
+
]} *)
38
+
39
+
(** {1 Handler Interface} *)
40
+
41
+
class type handler = object
42
+
method on_text : Response.Text.t -> unit
43
+
(** [on_text t] is called when text content is received from the assistant. *)
44
+
45
+
method on_tool_use : Response.Tool_use.t -> unit
46
+
(** [on_tool_use t] is called when the assistant requests a tool invocation.
47
+
The caller is responsible for responding with
48
+
{!Client.respond_to_tool}. *)
49
+
50
+
method on_tool_result : Content_block.Tool_result.t -> unit
51
+
(** [on_tool_result t] is called when a tool result is observed in the
52
+
message stream. This is typically an echo of what was sent to Claude. *)
53
+
54
+
method on_thinking : Response.Thinking.t -> unit
55
+
(** [on_thinking t] is called when internal reasoning content is received. *)
56
+
57
+
method on_init : Response.Init.t -> unit
58
+
(** [on_init t] is called when the session is initialized. This provides
59
+
session metadata like session_id and model. *)
60
+
61
+
method on_error : Response.Error.t -> unit
62
+
(** [on_error t] is called when an error occurs. Errors can come from the
63
+
system (e.g., CLI errors) or from the assistant (e.g., rate limits). *)
64
+
65
+
method on_complete : Response.Complete.t -> unit
66
+
(** [on_complete t] is called when the conversation completes. This provides
67
+
final metrics like duration, cost, and token usage. *)
68
+
end
69
+
(** The handler interface for processing response events.
70
+
71
+
Each method corresponds to a variant of {!Response.t}. Handlers can be
72
+
passed to {!Client.run} to process responses in an event-driven style. *)
73
+
74
+
(** {1 Concrete Implementations} *)
75
+
76
+
class default : handler
77
+
(** Default handler that does nothing for all events.
78
+
79
+
This is the recommended base class for most use cases. Override only the
80
+
methods you need:
81
+
82
+
{[
83
+
let handler = object
84
+
inherit Claude.Handler.default
85
+
method! on_text t = Printf.printf "Text: %s\n" (Response.Text.content t)
86
+
end
87
+
]}
88
+
89
+
Methods you don't override will simply be ignored, making this ideal for
90
+
prototyping and for cases where you only care about specific events. *)
91
+
92
+
class virtual abstract : object
93
+
method virtual on_text : Response.Text.t -> unit
94
+
(** [on_text t] must be implemented by subclasses. *)
95
+
96
+
method virtual on_tool_use : Response.Tool_use.t -> unit
97
+
(** [on_tool_use t] must be implemented by subclasses. *)
98
+
99
+
method virtual on_tool_result : Content_block.Tool_result.t -> unit
100
+
(** [on_tool_result t] must be implemented by subclasses. *)
101
+
102
+
method virtual on_thinking : Response.Thinking.t -> unit
103
+
(** [on_thinking t] must be implemented by subclasses. *)
104
+
105
+
method virtual on_init : Response.Init.t -> unit
106
+
(** [on_init t] must be implemented by subclasses. *)
107
+
108
+
method virtual on_error : Response.Error.t -> unit
109
+
(** [on_error t] must be implemented by subclasses. *)
110
+
111
+
method virtual on_complete : Response.Complete.t -> unit
112
+
(** [on_complete t] must be implemented by subclasses. *)
113
+
end
114
+
(** Abstract handler requiring all methods to be implemented.
115
+
116
+
Use this when you want compile-time guarantees that all events are handled:
117
+
118
+
{[
119
+
let handler = object
120
+
inherit Claude.Handler.abstract
121
+
method on_text t = (* required *)
122
+
method on_tool_use t = (* required *)
123
+
method on_tool_result t = (* required *)
124
+
method on_thinking t = (* required *)
125
+
method on_init t = (* required *)
126
+
method on_error t = (* required *)
127
+
method on_complete t = (* required *)
128
+
end
129
+
]}
130
+
131
+
The compiler will enforce that you implement all methods, ensuring no events
132
+
are silently ignored. *)
133
+
134
+
(** {1 Dispatch Functions} *)
135
+
136
+
val dispatch : #handler -> Response.t -> unit
137
+
(** [dispatch handler response] dispatches a response event to the appropriate
138
+
handler method based on the response type.
139
+
140
+
Example:
141
+
{[
142
+
let handler = object
143
+
inherit Claude.Handler.default
144
+
method! on_text t = print_endline (Response.Text.content t)
145
+
end in
146
+
dispatch handler (Response.Text text_event)
147
+
]} *)
148
+
149
+
val dispatch_all : #handler -> Response.t list -> unit
150
+
(** [dispatch_all handler responses] dispatches all response events to the
151
+
handler.
152
+
153
+
This is equivalent to calling [List.iter (dispatch handler) responses] but
154
+
may be more convenient:
155
+
156
+
{[
157
+
let responses = Client.receive_all client in
158
+
dispatch_all handler responses
159
+
]} *)
+381
-451
lib/hooks.ml
+381
-451
lib/hooks.ml
···
2
2
3
3
module Log = (val Logs.src_log src : Logs.LOG)
4
4
5
-
(** Hook events that can be intercepted *)
6
-
type event =
7
-
| Pre_tool_use
8
-
| Post_tool_use
9
-
| User_prompt_submit
10
-
| Stop
11
-
| Subagent_stop
12
-
| Pre_compact
13
-
14
-
let event_to_string = function
15
-
| Pre_tool_use -> "PreToolUse"
16
-
| Post_tool_use -> "PostToolUse"
17
-
| User_prompt_submit -> "UserPromptSubmit"
18
-
| Stop -> "Stop"
19
-
| Subagent_stop -> "SubagentStop"
20
-
| Pre_compact -> "PreCompact"
21
-
22
-
let event_of_string = function
23
-
| "PreToolUse" -> Pre_tool_use
24
-
| "PostToolUse" -> Post_tool_use
25
-
| "UserPromptSubmit" -> User_prompt_submit
26
-
| "Stop" -> Stop
27
-
| "SubagentStop" -> Subagent_stop
28
-
| "PreCompact" -> Pre_compact
29
-
| s -> raise (Invalid_argument (Printf.sprintf "Unknown hook event: %s" s))
30
-
31
-
let event_jsont : event Jsont.t =
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
-
]
41
-
42
-
(** Context provided to hook callbacks *)
43
-
module Context = struct
44
-
type t = {
45
-
signal : unit option; (* Future: abort signal support *)
46
-
unknown : Unknown.t;
47
-
}
48
-
49
-
let create ?(signal = None) ?(unknown = Unknown.empty) () =
50
-
{ signal; unknown }
51
-
52
-
let signal t = t.signal
53
-
let unknown t = t.unknown
54
-
55
-
let jsont : t Jsont.t =
56
-
let make unknown = { signal = None; unknown } in
57
-
Jsont.Object.map ~kind:"Context" make
58
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
59
-
|> Jsont.Object.finish
60
-
end
61
-
62
-
(** Hook decision control *)
63
-
type decision = Continue | Block
64
-
65
-
let decision_jsont : decision Jsont.t =
66
-
Jsont.enum [ ("continue", Continue); ("block", Block) ]
67
-
68
-
(** Wire format for hook-specific output that includes hookEventName *)
69
-
module Hook_specific_output = struct
70
-
type t = { hook_event_name : event; output : Jsont.json }
71
-
72
-
let create ~event ~output = { hook_event_name = event; output }
73
-
74
-
let to_json t =
75
-
(* Encode the event name *)
76
-
let event_name_json =
77
-
Jsont.Json.encode event_jsont t.hook_event_name
78
-
|> Err.get_ok ~msg:"Hook_specific_output.to_json: event_name encoding"
79
-
in
80
-
(* Merge hookEventName into the output object *)
81
-
match t.output with
82
-
| Jsont.Object (members, meta) ->
83
-
let hook_event_name_member =
84
-
(Jsont.Json.name "hookEventName", event_name_json)
85
-
in
86
-
Jsont.Object (hook_event_name_member :: members, meta)
87
-
| _ ->
88
-
(* If output is not an object, wrap it *)
89
-
Jsont.Object
90
-
( [
91
-
( Jsont.Json.name "hookEventName",
92
-
event_name_json );
93
-
],
94
-
Jsont.Meta.none )
95
-
end
96
-
97
-
type result = {
98
-
decision : decision option;
99
-
system_message : string option;
100
-
hook_specific_output : Jsont.json option;
101
-
unknown : Unknown.t;
102
-
}
103
-
(** Generic hook result *)
104
-
105
-
let result_jsont : result Jsont.t =
106
-
let make decision system_message hook_specific_output unknown =
107
-
{ decision; system_message; hook_specific_output; unknown }
108
-
in
109
-
Jsont.Object.map ~kind:"Result" make
110
-
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun r -> r.decision)
111
-
|> Jsont.Object.opt_mem "systemMessage" Jsont.string ~enc:(fun r ->
112
-
r.system_message)
113
-
|> Jsont.Object.opt_mem "hookSpecificOutput" Jsont.json ~enc:(fun r ->
114
-
r.hook_specific_output)
115
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
116
-
|> Jsont.Object.finish
5
+
(** {1 PreToolUse Hook} *)
117
6
118
-
(** {1 PreToolUse Hook} *)
119
7
module PreToolUse = struct
120
8
type input = {
121
9
session_id : string;
122
10
transcript_path : string;
123
11
tool_name : string;
124
-
tool_input : Jsont.json;
125
-
unknown : Unknown.t;
12
+
tool_input : Tool_input.t;
126
13
}
127
14
128
-
type t = input
129
-
130
-
let session_id t = t.session_id
131
-
let transcript_path t = t.transcript_path
132
-
let tool_name t = t.tool_name
133
-
let tool_input t = t.tool_input
134
-
let unknown t = t.unknown
135
-
136
-
let input_jsont : input Jsont.t =
137
-
let make session_id transcript_path tool_name tool_input unknown =
138
-
{ session_id; transcript_path; tool_name; tool_input; unknown }
139
-
in
140
-
Jsont.Object.map ~kind:"PreToolUseInput" make
141
-
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
142
-
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
143
-
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:tool_name
144
-
|> Jsont.Object.mem "tool_input" Jsont.json ~enc:tool_input
145
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
146
-
|> Jsont.Object.finish
147
-
148
-
let of_json json =
149
-
match Jsont.Json.decode input_jsont json with
150
-
| Ok v -> v
151
-
| Error msg -> raise (Invalid_argument ("PreToolUse: " ^ msg))
152
-
153
-
type permission_decision = [ `Allow | `Deny | `Ask ]
154
-
155
-
let permission_decision_jsont : permission_decision Jsont.t =
156
-
Jsont.enum [ ("allow", `Allow); ("deny", `Deny); ("ask", `Ask) ]
15
+
type decision = Allow | Deny | Ask
157
16
158
17
type output = {
159
-
permission_decision : permission_decision option;
160
-
permission_decision_reason : string option;
161
-
updated_input : Jsont.json option;
162
-
unknown : Unknown.t;
18
+
decision : decision option;
19
+
reason : string option;
20
+
updated_input : Tool_input.t option;
163
21
}
164
22
165
-
let output_jsont : output Jsont.t =
166
-
let make permission_decision permission_decision_reason updated_input
167
-
unknown =
168
-
{
169
-
permission_decision;
170
-
permission_decision_reason;
171
-
updated_input;
172
-
unknown;
173
-
}
174
-
in
175
-
Jsont.Object.map ~kind:"PreToolUseOutput" make
176
-
|> Jsont.Object.opt_mem "permissionDecision" permission_decision_jsont
177
-
~enc:(fun o -> o.permission_decision)
178
-
|> Jsont.Object.opt_mem "permissionDecisionReason" Jsont.string
179
-
~enc:(fun o -> o.permission_decision_reason)
180
-
|> Jsont.Object.opt_mem "updatedInput" Jsont.json ~enc:(fun o ->
181
-
o.updated_input)
182
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun o -> o.unknown)
183
-
|> Jsont.Object.finish
23
+
let allow ?reason ?updated_input () =
24
+
{ decision = Some Allow; reason; updated_input }
184
25
185
-
let output_to_json output =
186
-
let inner =
187
-
Jsont.Json.encode output_jsont output
188
-
|> Err.get_ok ~msg:"PreToolUse.output_to_json: "
189
-
in
190
-
Hook_specific_output.(create ~event:Pre_tool_use ~output:inner |> to_json)
26
+
let deny ?reason () = { decision = Some Deny; reason; updated_input = None }
27
+
let ask ?reason () = { decision = Some Ask; reason; updated_input = None }
191
28
192
-
let allow ?reason ?updated_input ?(unknown = Unknown.empty) () =
193
-
{
194
-
permission_decision = Some `Allow;
195
-
permission_decision_reason = reason;
196
-
updated_input;
197
-
unknown;
198
-
}
29
+
let continue () =
30
+
{ decision = None; reason = None; updated_input = None }
199
31
200
-
let deny ?reason ?(unknown = Unknown.empty) () =
201
-
{
202
-
permission_decision = Some `Deny;
203
-
permission_decision_reason = reason;
204
-
updated_input = None;
205
-
unknown;
206
-
}
32
+
type callback = input -> output
207
33
208
-
let ask ?reason ?(unknown = Unknown.empty) () =
34
+
let input_of_proto proto =
209
35
{
210
-
permission_decision = Some `Ask;
211
-
permission_decision_reason = reason;
212
-
updated_input = None;
213
-
unknown;
36
+
session_id = Proto.Hooks.PreToolUse.Input.session_id proto;
37
+
transcript_path = Proto.Hooks.PreToolUse.Input.transcript_path proto;
38
+
tool_name = Proto.Hooks.PreToolUse.Input.tool_name proto;
39
+
tool_input =
40
+
Tool_input.of_json (Proto.Hooks.PreToolUse.Input.tool_input proto);
214
41
}
215
42
216
-
let continue ?(unknown = Unknown.empty) () =
217
-
{
218
-
permission_decision = None;
219
-
permission_decision_reason = None;
220
-
updated_input = None;
221
-
unknown;
222
-
}
43
+
let output_to_proto output =
44
+
match output.decision with
45
+
| None -> Proto.Hooks.PreToolUse.Output.continue ()
46
+
| Some Allow ->
47
+
let updated_input =
48
+
Option.map Tool_input.to_json output.updated_input
49
+
in
50
+
Proto.Hooks.PreToolUse.Output.allow ?reason:output.reason
51
+
?updated_input ()
52
+
| Some Deny -> Proto.Hooks.PreToolUse.Output.deny ?reason:output.reason ()
53
+
| Some Ask -> Proto.Hooks.PreToolUse.Output.ask ?reason:output.reason ()
223
54
end
224
55
225
56
(** {1 PostToolUse Hook} *)
57
+
226
58
module PostToolUse = struct
227
59
type input = {
228
60
session_id : string;
229
61
transcript_path : string;
230
62
tool_name : string;
231
-
tool_input : Jsont.json;
63
+
tool_input : Tool_input.t;
232
64
tool_response : Jsont.json;
233
-
unknown : Unknown.t;
234
65
}
235
66
236
-
type t = input
237
-
238
-
let session_id t = t.session_id
239
-
let transcript_path t = t.transcript_path
240
-
let tool_name t = t.tool_name
241
-
let tool_input t = t.tool_input
242
-
let tool_response t = t.tool_response
243
-
let unknown t = t.unknown
244
-
245
-
let input_jsont : input Jsont.t =
246
-
let make session_id transcript_path tool_name tool_input tool_response
247
-
unknown =
248
-
{
249
-
session_id;
250
-
transcript_path;
251
-
tool_name;
252
-
tool_input;
253
-
tool_response;
254
-
unknown;
255
-
}
256
-
in
257
-
Jsont.Object.map ~kind:"PostToolUseInput" make
258
-
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
259
-
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
260
-
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:tool_name
261
-
|> Jsont.Object.mem "tool_input" Jsont.json ~enc:tool_input
262
-
|> Jsont.Object.mem "tool_response" Jsont.json ~enc:tool_response
263
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
264
-
|> Jsont.Object.finish
265
-
266
-
let of_json json =
267
-
match Jsont.Json.decode input_jsont json with
268
-
| Ok v -> v
269
-
| Error msg -> raise (Invalid_argument ("PostToolUse: " ^ msg))
270
-
271
67
type output = {
272
-
decision : decision option;
68
+
block : bool;
273
69
reason : string option;
274
70
additional_context : string option;
275
-
unknown : Unknown.t;
276
71
}
277
72
278
-
let output_jsont : output Jsont.t =
279
-
let make decision reason additional_context unknown =
280
-
{ decision; reason; additional_context; unknown }
281
-
in
282
-
Jsont.Object.map ~kind:"PostToolUseOutput" make
283
-
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o -> o.decision)
284
-
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
285
-
|> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o ->
286
-
o.additional_context)
287
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun o -> o.unknown)
288
-
|> Jsont.Object.finish
73
+
let continue ?additional_context () =
74
+
{ block = false; reason = None; additional_context }
289
75
290
-
let output_to_json output =
291
-
let inner =
292
-
Jsont.Json.encode output_jsont output
293
-
|> Err.get_ok ~msg:"PostToolUse.output_to_json: "
294
-
in
295
-
Hook_specific_output.(create ~event:Post_tool_use ~output:inner |> to_json)
76
+
let block ?reason ?additional_context () =
77
+
{ block = true; reason; additional_context }
296
78
297
-
let continue ?additional_context ?(unknown = Unknown.empty) () =
298
-
{ decision = None; reason = None; additional_context; unknown }
79
+
type callback = input -> output
299
80
300
-
let block ?reason ?additional_context ?(unknown = Unknown.empty) () =
301
-
{ decision = Some Block; reason; additional_context; unknown }
81
+
let input_of_proto proto =
82
+
{
83
+
session_id = Proto.Hooks.PostToolUse.Input.session_id proto;
84
+
transcript_path = Proto.Hooks.PostToolUse.Input.transcript_path proto;
85
+
tool_name = Proto.Hooks.PostToolUse.Input.tool_name proto;
86
+
tool_input =
87
+
Tool_input.of_json (Proto.Hooks.PostToolUse.Input.tool_input proto);
88
+
tool_response = Proto.Hooks.PostToolUse.Input.tool_response proto;
89
+
}
90
+
91
+
let output_to_proto output =
92
+
if output.block then
93
+
Proto.Hooks.PostToolUse.Output.block ?reason:output.reason
94
+
?additional_context:output.additional_context ()
95
+
else
96
+
Proto.Hooks.PostToolUse.Output.continue
97
+
?additional_context:output.additional_context ()
302
98
end
303
99
304
100
(** {1 UserPromptSubmit Hook} *)
101
+
305
102
module UserPromptSubmit = struct
306
103
type input = {
307
104
session_id : string;
308
105
transcript_path : string;
309
106
prompt : string;
310
-
unknown : Unknown.t;
311
107
}
312
108
313
-
type t = input
314
-
315
-
let session_id t = t.session_id
316
-
let transcript_path t = t.transcript_path
317
-
let prompt t = t.prompt
318
-
let unknown t = t.unknown
319
-
320
-
let input_jsont : input Jsont.t =
321
-
let make session_id transcript_path prompt unknown =
322
-
{ session_id; transcript_path; prompt; unknown }
323
-
in
324
-
Jsont.Object.map ~kind:"UserPromptSubmitInput" make
325
-
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
326
-
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
327
-
|> Jsont.Object.mem "prompt" Jsont.string ~enc:prompt
328
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
329
-
|> Jsont.Object.finish
330
-
331
-
let of_json json =
332
-
match Jsont.Json.decode input_jsont json with
333
-
| Ok v -> v
334
-
| Error msg -> raise (Invalid_argument ("UserPromptSubmit: " ^ msg))
335
-
336
109
type output = {
337
-
decision : decision option;
110
+
block : bool;
338
111
reason : string option;
339
112
additional_context : string option;
340
-
unknown : Unknown.t;
341
113
}
342
114
343
-
let output_jsont : output Jsont.t =
344
-
let make decision reason additional_context unknown =
345
-
{ decision; reason; additional_context; unknown }
346
-
in
347
-
Jsont.Object.map ~kind:"UserPromptSubmitOutput" make
348
-
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o -> o.decision)
349
-
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
350
-
|> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o ->
351
-
o.additional_context)
352
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun o -> o.unknown)
353
-
|> Jsont.Object.finish
115
+
let continue ?additional_context () =
116
+
{ block = false; reason = None; additional_context }
354
117
355
-
let output_to_json output =
356
-
let inner =
357
-
Jsont.Json.encode output_jsont output
358
-
|> Err.get_ok ~msg:"UserPromptSubmit.output_to_json: "
359
-
in
360
-
Hook_specific_output.(
361
-
create ~event:User_prompt_submit ~output:inner |> to_json)
118
+
let block ?reason () = { block = true; reason; additional_context = None }
362
119
363
-
let continue ?additional_context ?(unknown = Unknown.empty) () =
364
-
{ decision = None; reason = None; additional_context; unknown }
120
+
type callback = input -> output
121
+
122
+
let input_of_proto proto =
123
+
{
124
+
session_id = Proto.Hooks.UserPromptSubmit.Input.session_id proto;
125
+
transcript_path =
126
+
Proto.Hooks.UserPromptSubmit.Input.transcript_path proto;
127
+
prompt = Proto.Hooks.UserPromptSubmit.Input.prompt proto;
128
+
}
365
129
366
-
let block ?reason ?(unknown = Unknown.empty) () =
367
-
{ decision = Some Block; reason; additional_context = None; unknown }
130
+
let output_to_proto output =
131
+
if output.block then
132
+
Proto.Hooks.UserPromptSubmit.Output.block ?reason:output.reason ()
133
+
else
134
+
Proto.Hooks.UserPromptSubmit.Output.continue
135
+
?additional_context:output.additional_context ()
368
136
end
369
137
370
138
(** {1 Stop Hook} *)
139
+
371
140
module Stop = struct
372
141
type input = {
373
142
session_id : string;
374
143
transcript_path : string;
375
144
stop_hook_active : bool;
376
-
unknown : Unknown.t;
377
145
}
378
146
379
-
type t = input
380
-
381
-
let session_id t = t.session_id
382
-
let transcript_path t = t.transcript_path
383
-
let stop_hook_active t = t.stop_hook_active
384
-
let unknown t = t.unknown
385
-
386
-
let input_jsont : input Jsont.t =
387
-
let make session_id transcript_path stop_hook_active unknown =
388
-
{ session_id; transcript_path; stop_hook_active; unknown }
389
-
in
390
-
Jsont.Object.map ~kind:"StopInput" make
391
-
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
392
-
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
393
-
|> Jsont.Object.mem "stop_hook_active" Jsont.bool ~enc:stop_hook_active
394
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
395
-
|> Jsont.Object.finish
396
-
397
-
let of_json json =
398
-
match Jsont.Json.decode input_jsont json with
399
-
| Ok v -> v
400
-
| Error msg -> raise (Invalid_argument ("Stop: " ^ msg))
147
+
type output = { block : bool; reason : string option }
401
148
402
-
type output = {
403
-
decision : decision option;
404
-
reason : string option;
405
-
unknown : Unknown.t;
406
-
}
407
-
408
-
let output_jsont : output Jsont.t =
409
-
let make decision reason unknown = { decision; reason; unknown } in
410
-
Jsont.Object.map ~kind:"StopOutput" make
411
-
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o -> o.decision)
412
-
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
413
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun o -> o.unknown)
414
-
|> Jsont.Object.finish
149
+
let continue () = { block = false; reason = None }
150
+
let block ?reason () = { block = true; reason }
415
151
416
-
let output_to_json output =
417
-
let inner =
418
-
Jsont.Json.encode output_jsont output
419
-
|> Err.get_ok ~msg:"Stop.output_to_json: "
420
-
in
421
-
Hook_specific_output.(create ~event:Stop ~output:inner |> to_json)
152
+
type callback = input -> output
422
153
423
-
let continue ?(unknown = Unknown.empty) () =
424
-
{ decision = None; reason = None; unknown }
154
+
let input_of_proto proto =
155
+
{
156
+
session_id = Proto.Hooks.Stop.Input.session_id proto;
157
+
transcript_path = Proto.Hooks.Stop.Input.transcript_path proto;
158
+
stop_hook_active = Proto.Hooks.Stop.Input.stop_hook_active proto;
159
+
}
425
160
426
-
let block ?reason ?(unknown = Unknown.empty) () =
427
-
{ decision = Some Block; reason; unknown }
161
+
let output_to_proto output =
162
+
if output.block then
163
+
Proto.Hooks.Stop.Output.block ?reason:output.reason ()
164
+
else Proto.Hooks.Stop.Output.continue ()
428
165
end
429
166
430
-
(** {1 SubagentStop Hook} - Same structure as Stop *)
167
+
(** {1 SubagentStop Hook} *)
168
+
431
169
module SubagentStop = struct
432
170
type input = Stop.input
433
-
type t = input
434
171
type output = Stop.output
435
172
436
-
let session_id = Stop.session_id
437
-
let transcript_path = Stop.transcript_path
438
-
let stop_hook_active = Stop.stop_hook_active
439
-
let unknown = Stop.unknown
440
-
let input_jsont = Stop.input_jsont
441
-
let of_json = Stop.of_json
442
-
let output_jsont = Stop.output_jsont
443
173
let continue = Stop.continue
444
174
let block = Stop.block
445
175
446
-
let output_to_json output =
447
-
let inner =
448
-
Jsont.Json.encode output_jsont output
449
-
|> Err.get_ok ~msg:"SubagentStop.output_to_json: "
450
-
in
451
-
Hook_specific_output.(create ~event:Subagent_stop ~output:inner |> to_json)
176
+
type callback = input -> output
177
+
178
+
let input_of_proto = Stop.input_of_proto
179
+
180
+
(* Since Proto.Hooks.SubagentStop.Output.t = Proto.Hooks.Stop.Output.t,
181
+
we can use Stop.output_to_proto directly *)
182
+
let output_to_proto = Stop.output_to_proto
452
183
end
453
184
454
185
(** {1 PreCompact Hook} *)
186
+
455
187
module PreCompact = struct
456
-
type input = {
457
-
session_id : string;
458
-
transcript_path : string;
459
-
unknown : Unknown.t;
460
-
}
188
+
type input = { session_id : string; transcript_path : string }
461
189
462
-
type t = input
190
+
type callback = input -> unit
463
191
464
-
let session_id t = t.session_id
465
-
let transcript_path t = t.transcript_path
466
-
let unknown t = t.unknown
192
+
let input_of_proto proto =
193
+
{
194
+
session_id = Proto.Hooks.PreCompact.Input.session_id proto;
195
+
transcript_path = Proto.Hooks.PreCompact.Input.transcript_path proto;
196
+
}
197
+
end
467
198
468
-
let input_jsont : input Jsont.t =
469
-
let make session_id transcript_path unknown =
470
-
{ session_id; transcript_path; unknown }
471
-
in
472
-
Jsont.Object.map ~kind:"PreCompactInput" make
473
-
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
474
-
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
475
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
476
-
|> Jsont.Object.finish
199
+
(** {1 Hook Configuration} *)
477
200
478
-
let of_json json =
479
-
match Jsont.Json.decode input_jsont json with
480
-
| Ok v -> v
481
-
| Error msg -> raise (Invalid_argument ("PreCompact: " ^ msg))
201
+
(* Internal representation of hooks *)
202
+
type hook_entry =
203
+
| PreToolUseHook of (string option * PreToolUse.callback)
204
+
| PostToolUseHook of (string option * PostToolUse.callback)
205
+
| UserPromptSubmitHook of UserPromptSubmit.callback
206
+
| StopHook of Stop.callback
207
+
| SubagentStopHook of SubagentStop.callback
208
+
| PreCompactHook of PreCompact.callback
482
209
483
-
type output = unit (* No specific output for PreCompact *)
210
+
type t = hook_entry list
484
211
485
-
let output_to_json () =
486
-
let inner = Jsont.Object ([], Jsont.Meta.none) in
487
-
Hook_specific_output.(create ~event:Pre_compact ~output:inner |> to_json)
212
+
let empty = []
488
213
489
-
let continue () = ()
490
-
end
214
+
let on_pre_tool_use ?pattern callback config =
215
+
PreToolUseHook (pattern, callback) :: config
491
216
492
-
type callback =
493
-
input:Jsont.json -> tool_use_id:string option -> context:Context.t -> result
494
-
(** {1 Generic Callback Type} *)
217
+
let on_post_tool_use ?pattern callback config =
218
+
PostToolUseHook (pattern, callback) :: config
495
219
496
-
type matcher = { matcher : string option; callbacks : callback list }
497
-
(** {1 Matcher Configuration} *)
220
+
let on_user_prompt_submit callback config =
221
+
UserPromptSubmitHook callback :: config
498
222
499
-
type config = (event * matcher list) list
223
+
let on_stop callback config = StopHook callback :: config
224
+
let on_subagent_stop callback config = SubagentStopHook callback :: config
225
+
let on_pre_compact callback config = PreCompactHook callback :: config
500
226
501
-
(** {1 Result Builders} *)
502
-
let continue ?system_message ?hook_specific_output ?(unknown = Unknown.empty) ()
503
-
=
504
-
{ decision = None; system_message; hook_specific_output; unknown }
227
+
(** {1 Internal - Conversion to Wire Format} *)
505
228
506
-
let block ?system_message ?hook_specific_output ?(unknown = Unknown.empty) () =
507
-
{ decision = Some Block; system_message; hook_specific_output; unknown }
229
+
let get_callbacks config =
230
+
(* Group hooks by event type *)
231
+
let pre_tool_use_hooks = ref [] in
232
+
let post_tool_use_hooks = ref [] in
233
+
let user_prompt_submit_hooks = ref [] in
234
+
let stop_hooks = ref [] in
235
+
let subagent_stop_hooks = ref [] in
236
+
let pre_compact_hooks = ref [] in
508
237
509
-
(** {1 Matcher Builders} *)
510
-
let matcher ?pattern callbacks = { matcher = pattern; callbacks }
238
+
List.iter
239
+
(function
240
+
| PreToolUseHook (pattern, callback) ->
241
+
pre_tool_use_hooks := (pattern, callback) :: !pre_tool_use_hooks
242
+
| PostToolUseHook (pattern, callback) ->
243
+
post_tool_use_hooks := (pattern, callback) :: !post_tool_use_hooks
244
+
| UserPromptSubmitHook callback ->
245
+
user_prompt_submit_hooks := (None, callback) :: !user_prompt_submit_hooks
246
+
| StopHook callback -> stop_hooks := (None, callback) :: !stop_hooks
247
+
| SubagentStopHook callback ->
248
+
subagent_stop_hooks := (None, callback) :: !subagent_stop_hooks
249
+
| PreCompactHook callback ->
250
+
pre_compact_hooks := (None, callback) :: !pre_compact_hooks)
251
+
config;
511
252
512
-
(** {1 Config Builders} *)
513
-
let empty = []
253
+
(* Convert each group to wire format *)
254
+
let result = [] in
514
255
515
-
let add event matchers config = (event, matchers) :: config
256
+
(* PreToolUse *)
257
+
let result =
258
+
if !pre_tool_use_hooks <> [] then
259
+
let wire_callbacks =
260
+
List.map
261
+
(fun (pattern, callback) ->
262
+
let wire_callback json =
263
+
(* Decode JSON to Proto input *)
264
+
let proto_input =
265
+
match
266
+
Jsont.Json.decode Proto.Hooks.PreToolUse.Input.jsont json
267
+
with
268
+
| Ok input -> input
269
+
| Error msg ->
270
+
Log.err (fun m ->
271
+
m "PreToolUse: failed to decode input: %s" msg);
272
+
raise (Invalid_argument ("PreToolUse input: " ^ msg))
273
+
in
274
+
(* Convert to typed input *)
275
+
let typed_input = PreToolUse.input_of_proto proto_input in
276
+
(* Invoke user callback *)
277
+
let typed_output = callback typed_input in
278
+
(* Convert back to Proto output *)
279
+
let proto_output = PreToolUse.output_to_proto typed_output in
280
+
(* Encode as hook_specific_output *)
281
+
let hook_specific_output =
282
+
match
283
+
Jsont.Json.encode Proto.Hooks.PreToolUse.Output.jsont
284
+
proto_output
285
+
with
286
+
| Ok json -> json
287
+
| Error msg ->
288
+
failwith ("PreToolUse output encoding: " ^ msg)
289
+
in
290
+
(* Return wire format result *)
291
+
Proto.Hooks.continue ~hook_specific_output ()
292
+
in
293
+
(pattern, wire_callback))
294
+
!pre_tool_use_hooks
295
+
in
296
+
(Proto.Hooks.Pre_tool_use, wire_callbacks) :: result
297
+
else result
298
+
in
516
299
517
-
(** {1 JSON Conversion} *)
518
-
let result_to_json result =
519
-
match Jsont.Json.encode result_jsont result with
520
-
| Ok json -> json
521
-
| Error msg -> failwith ("result_to_json: " ^ msg)
300
+
(* PostToolUse *)
301
+
let result =
302
+
if !post_tool_use_hooks <> [] then
303
+
let wire_callbacks =
304
+
List.map
305
+
(fun (pattern, callback) ->
306
+
let wire_callback json =
307
+
let proto_input =
308
+
match
309
+
Jsont.Json.decode Proto.Hooks.PostToolUse.Input.jsont json
310
+
with
311
+
| Ok input -> input
312
+
| Error msg ->
313
+
Log.err (fun m ->
314
+
m "PostToolUse: failed to decode input: %s" msg);
315
+
raise (Invalid_argument ("PostToolUse input: " ^ msg))
316
+
in
317
+
let typed_input = PostToolUse.input_of_proto proto_input in
318
+
let typed_output = callback typed_input in
319
+
let proto_output = PostToolUse.output_to_proto typed_output in
320
+
let hook_specific_output =
321
+
match
322
+
Jsont.Json.encode Proto.Hooks.PostToolUse.Output.jsont
323
+
proto_output
324
+
with
325
+
| Ok json -> json
326
+
| Error msg ->
327
+
failwith ("PostToolUse output encoding: " ^ msg)
328
+
in
329
+
if typed_output.block then
330
+
Proto.Hooks.block ~hook_specific_output ()
331
+
else Proto.Hooks.continue ~hook_specific_output ()
332
+
in
333
+
(pattern, wire_callback))
334
+
!post_tool_use_hooks
335
+
in
336
+
(Proto.Hooks.Post_tool_use, wire_callbacks) :: result
337
+
else result
338
+
in
522
339
523
-
(** Wire codec for hook matcher in protocol format *)
524
-
module Protocol_matcher_wire = struct
525
-
type t = { matcher : string option; callbacks : Jsont.json list }
340
+
(* UserPromptSubmit *)
341
+
let result =
342
+
if !user_prompt_submit_hooks <> [] then
343
+
let wire_callbacks =
344
+
List.map
345
+
(fun (pattern, callback) ->
346
+
let wire_callback json =
347
+
let proto_input =
348
+
match
349
+
Jsont.Json.decode Proto.Hooks.UserPromptSubmit.Input.jsont
350
+
json
351
+
with
352
+
| Ok input -> input
353
+
| Error msg ->
354
+
Log.err (fun m ->
355
+
m "UserPromptSubmit: failed to decode input: %s" msg);
356
+
raise (Invalid_argument ("UserPromptSubmit input: " ^ msg))
357
+
in
358
+
let typed_input = UserPromptSubmit.input_of_proto proto_input in
359
+
let typed_output = callback typed_input in
360
+
let proto_output =
361
+
UserPromptSubmit.output_to_proto typed_output
362
+
in
363
+
let hook_specific_output =
364
+
match
365
+
Jsont.Json.encode Proto.Hooks.UserPromptSubmit.Output.jsont
366
+
proto_output
367
+
with
368
+
| Ok json -> json
369
+
| Error msg ->
370
+
failwith ("UserPromptSubmit output encoding: " ^ msg)
371
+
in
372
+
if typed_output.block then
373
+
Proto.Hooks.block ~hook_specific_output ()
374
+
else Proto.Hooks.continue ~hook_specific_output ()
375
+
in
376
+
(pattern, wire_callback))
377
+
!user_prompt_submit_hooks
378
+
in
379
+
(Proto.Hooks.User_prompt_submit, wire_callbacks) :: result
380
+
else result
381
+
in
526
382
527
-
let jsont : t Jsont.t =
528
-
let make matcher callbacks = { matcher; callbacks } in
529
-
Jsont.Object.map ~kind:"ProtocolMatcher" make
530
-
|> Jsont.Object.opt_mem "matcher" Jsont.string ~enc:(fun r -> r.matcher)
531
-
|> Jsont.Object.mem "callbacks" (Jsont.list Jsont.json) ~enc:(fun r ->
532
-
r.callbacks)
533
-
|> Jsont.Object.finish
383
+
(* Stop *)
384
+
let result =
385
+
if !stop_hooks <> [] then
386
+
let wire_callbacks =
387
+
List.map
388
+
(fun (pattern, callback) ->
389
+
let wire_callback json =
390
+
let proto_input =
391
+
match Jsont.Json.decode Proto.Hooks.Stop.Input.jsont json with
392
+
| Ok input -> input
393
+
| Error msg ->
394
+
Log.err (fun m ->
395
+
m "Stop: failed to decode input: %s" msg);
396
+
raise (Invalid_argument ("Stop input: " ^ msg))
397
+
in
398
+
let typed_input = Stop.input_of_proto proto_input in
399
+
let typed_output = callback typed_input in
400
+
let proto_output = Stop.output_to_proto typed_output in
401
+
let hook_specific_output =
402
+
match
403
+
Jsont.Json.encode Proto.Hooks.Stop.Output.jsont proto_output
404
+
with
405
+
| Ok json -> json
406
+
| Error msg -> failwith ("Stop output encoding: " ^ msg)
407
+
in
408
+
if typed_output.block then
409
+
Proto.Hooks.block ~hook_specific_output ()
410
+
else Proto.Hooks.continue ~hook_specific_output ()
411
+
in
412
+
(pattern, wire_callback))
413
+
!stop_hooks
414
+
in
415
+
(Proto.Hooks.Stop, wire_callbacks) :: result
416
+
else result
417
+
in
534
418
535
-
let encode m =
536
-
match Jsont.Json.encode jsont m with
537
-
| Ok json -> json
538
-
| Error msg -> failwith ("Protocol_matcher_wire.encode: " ^ msg)
539
-
end
419
+
(* SubagentStop *)
420
+
let result =
421
+
if !subagent_stop_hooks <> [] then
422
+
let wire_callbacks =
423
+
List.map
424
+
(fun (pattern, callback) ->
425
+
let wire_callback json =
426
+
let proto_input =
427
+
match
428
+
Jsont.Json.decode Proto.Hooks.SubagentStop.Input.jsont json
429
+
with
430
+
| Ok input -> input
431
+
| Error msg ->
432
+
Log.err (fun m ->
433
+
m "SubagentStop: failed to decode input: %s" msg);
434
+
raise (Invalid_argument ("SubagentStop input: " ^ msg))
435
+
in
436
+
let typed_input = SubagentStop.input_of_proto proto_input in
437
+
let typed_output = callback typed_input in
438
+
let proto_output = SubagentStop.output_to_proto typed_output in
439
+
let hook_specific_output =
440
+
match
441
+
Jsont.Json.encode Proto.Hooks.SubagentStop.Output.jsont
442
+
proto_output
443
+
with
444
+
| Ok json -> json
445
+
| Error msg ->
446
+
failwith ("SubagentStop output encoding: " ^ msg)
447
+
in
448
+
if typed_output.block then
449
+
Proto.Hooks.block ~hook_specific_output ()
450
+
else Proto.Hooks.continue ~hook_specific_output ()
451
+
in
452
+
(pattern, wire_callback))
453
+
!subagent_stop_hooks
454
+
in
455
+
(Proto.Hooks.Subagent_stop, wire_callbacks) :: result
456
+
else result
457
+
in
540
458
541
-
let config_to_protocol_format config =
542
-
let hooks_dict =
543
-
List.map
544
-
(fun (event, matchers) ->
545
-
let event_name = event_to_string event in
546
-
let matchers_json =
547
-
List.map
548
-
(fun m ->
549
-
(* matcher and hookCallbackIds will be filled in by client *)
550
-
Protocol_matcher_wire.encode
551
-
{ matcher = m.matcher; callbacks = [] })
552
-
matchers
553
-
in
554
-
Jsont.Json.mem
555
-
(Jsont.Json.name event_name)
556
-
(Jsont.Json.list matchers_json))
557
-
config
459
+
(* PreCompact *)
460
+
let result =
461
+
if !pre_compact_hooks <> [] then
462
+
let wire_callbacks =
463
+
List.map
464
+
(fun (pattern, callback) ->
465
+
let wire_callback json =
466
+
let proto_input =
467
+
match
468
+
Jsont.Json.decode Proto.Hooks.PreCompact.Input.jsont json
469
+
with
470
+
| Ok input -> input
471
+
| Error msg ->
472
+
Log.err (fun m ->
473
+
m "PreCompact: failed to decode input: %s" msg);
474
+
raise (Invalid_argument ("PreCompact input: " ^ msg))
475
+
in
476
+
let typed_input = PreCompact.input_of_proto proto_input in
477
+
(* Invoke user callback (returns unit) *)
478
+
callback typed_input;
479
+
(* PreCompact has no specific output *)
480
+
Proto.Hooks.continue ()
481
+
in
482
+
(pattern, wire_callback))
483
+
!pre_compact_hooks
484
+
in
485
+
(Proto.Hooks.Pre_compact, wire_callbacks) :: result
486
+
else result
558
487
in
559
-
Jsont.Json.object' hooks_dict
488
+
489
+
List.rev result
+223
-237
lib/hooks.mli
+223
-237
lib/hooks.mli
···
1
-
(** Claude Code Hooks System
1
+
(** Fully typed hook callbacks.
2
2
3
3
Hooks allow you to intercept and control events in Claude Code sessions,
4
-
such as tool usage, prompt submission, and session stops.
4
+
using fully typed OCaml values instead of raw JSON.
5
5
6
6
{1 Overview}
7
7
8
-
Hooks are organized by event type, with each event having:
9
-
- A typed input structure (accessible via submodules)
10
-
- A typed output structure for responses
8
+
This module provides a high-level, type-safe interface to hooks. Each hook
9
+
type has:
10
+
- Fully typed input records using {!Tool_input.t}
11
+
- Fully typed output records
11
12
- Helper functions for common responses
13
+
- Conversion functions to/from wire format ({!Proto.Hooks})
12
14
13
15
{1 Example Usage}
14
16
···
16
18
open Eio.Std
17
19
18
20
(* Block dangerous bash commands *)
19
-
let get_string json key =
20
-
match json with
21
-
| Jsont.Object (members, _) ->
22
-
List.find_map (fun ((name, _), value) ->
23
-
if name = key then
24
-
match value with
25
-
| Jsont.String (s, _) -> Some s
26
-
| _ -> None
27
-
else None
28
-
) members
29
-
| _ -> None
30
-
in
31
-
let block_rm_rf ~input ~tool_use_id:_ ~context:_ =
32
-
let hook = Hooks.PreToolUse.of_json input in
33
-
if Hooks.PreToolUse.tool_name hook = "Bash" then
34
-
let tool_input = Hooks.PreToolUse.tool_input hook in
35
-
match get_string tool_input "command" with
21
+
let block_rm_rf input =
22
+
if input.Hooks.PreToolUse.tool_name = "Bash" then
23
+
match Tool_input.get_string input.tool_input "command" with
36
24
| Some cmd when String.contains cmd "rm -rf" ->
37
-
let output = Hooks.PreToolUse.deny ~reason:"Dangerous command" () in
38
-
Hooks.continue
39
-
~hook_specific_output:(Hooks.PreToolUse.output_to_json output)
40
-
()
41
-
| _ -> Hooks.continue ()
42
-
else Hooks.continue ()
25
+
Hooks.PreToolUse.deny ~reason:"Dangerous command" ()
26
+
| _ -> Hooks.PreToolUse.continue ()
27
+
else Hooks.PreToolUse.continue ()
43
28
44
29
let hooks =
45
30
Hooks.empty
46
-
|> Hooks.add Hooks.Pre_tool_use [
47
-
Hooks.matcher ~pattern:"Bash" [block_rm_rf]
48
-
]
31
+
|> Hooks.on_pre_tool_use ~pattern:"Bash" block_rm_rf
49
32
50
-
let options = Claude.Options.create ~hooks:(Some hooks) () in
33
+
let options = Claude.Options.create ~hooks () in
51
34
let client = Claude.Client.create ~options ~sw ~process_mgr () in
52
35
]} *)
53
36
54
37
val src : Logs.Src.t
55
38
(** The log source for hooks *)
56
39
57
-
(** {1 Hook Events} *)
58
-
59
-
(** Hook event types *)
60
-
type event =
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 *)
67
-
68
-
val event_to_string : event -> string
69
-
val event_of_string : string -> event
70
-
val event_jsont : event Jsont.t
71
-
72
-
(** {1 Context} *)
73
-
74
-
module Context : sig
75
-
type t = { signal : unit option; unknown : Unknown.t }
76
-
77
-
val create : ?signal:unit option -> ?unknown:Unknown.t -> unit -> t
78
-
val signal : t -> unit option
79
-
val unknown : t -> Unknown.t
80
-
val jsont : t Jsont.t
81
-
end
82
-
83
-
(** {1 Decisions} *)
84
-
85
-
type decision =
86
-
| Continue (** Allow the action to proceed *)
87
-
| Block (** Block the action *)
88
-
89
-
val decision_jsont : decision Jsont.t
90
-
91
-
(** {1 Generic Hook Result} *)
92
-
93
-
type result = {
94
-
decision : decision option;
95
-
system_message : string option;
96
-
hook_specific_output : Jsont.json option;
97
-
unknown : Unknown.t;
98
-
}
99
-
(** Generic result structure for hooks *)
100
-
101
-
val result_jsont : result Jsont.t
102
-
103
-
(** {1 Typed Hook Modules} *)
40
+
(** {1 Hook Types} *)
104
41
105
42
(** PreToolUse hook - fires before tool execution *)
106
43
module PreToolUse : sig
44
+
(** {2 Input} *)
45
+
107
46
type input = {
108
47
session_id : string;
109
48
transcript_path : string;
110
49
tool_name : string;
111
-
tool_input : Jsont.json;
112
-
unknown : Unknown.t;
50
+
tool_input : Tool_input.t;
113
51
}
114
-
(** Typed input for PreToolUse hooks *)
52
+
(** Input provided to PreToolUse hooks. *)
115
53
116
-
type t = input
54
+
(** {2 Output} *)
117
55
118
-
val of_json : Jsont.json -> t
119
-
(** Parse hook input from JSON *)
56
+
type decision =
57
+
| Allow
58
+
| Deny
59
+
| Ask
60
+
(** Permission decision for tool usage. *)
120
61
121
-
val session_id : t -> string
122
-
(** {2 Accessors} *)
62
+
type output = {
63
+
decision : decision option;
64
+
reason : string option;
65
+
updated_input : Tool_input.t option;
66
+
}
67
+
(** Output from PreToolUse hooks. *)
123
68
124
-
val transcript_path : t -> string
125
-
val tool_name : t -> string
126
-
val tool_input : t -> Jsont.json
127
-
val unknown : t -> Unknown.t
128
-
val input_jsont : input Jsont.t
69
+
(** {2 Response Builders} *)
129
70
130
-
type permission_decision = [ `Allow | `Deny | `Ask ]
131
-
(** Permission decision for tool usage *)
71
+
val allow : ?reason:string -> ?updated_input:Tool_input.t -> unit -> output
72
+
(** [allow ?reason ?updated_input ()] creates an allow response.
73
+
@param reason Optional explanation for allowing
74
+
@param updated_input Optional modified tool input *)
132
75
133
-
val permission_decision_jsont : permission_decision Jsont.t
76
+
val deny : ?reason:string -> unit -> output
77
+
(** [deny ?reason ()] creates a deny response.
78
+
@param reason Optional explanation for denying *)
134
79
135
-
type output = {
136
-
permission_decision : permission_decision option;
137
-
permission_decision_reason : string option;
138
-
updated_input : Jsont.json option;
139
-
unknown : Unknown.t;
140
-
}
141
-
(** Typed output for PreToolUse hooks *)
80
+
val ask : ?reason:string -> unit -> output
81
+
(** [ask ?reason ()] creates an ask response to prompt the user.
82
+
@param reason Optional explanation for asking *)
142
83
143
-
val output_jsont : output Jsont.t
84
+
val continue : unit -> output
85
+
(** [continue ()] creates a continue response with no decision. *)
86
+
87
+
(** {2 Callback Type} *)
88
+
89
+
type callback = input -> output
90
+
(** Callback function type for PreToolUse hooks. *)
144
91
145
-
val allow :
146
-
?reason:string ->
147
-
?updated_input:Jsont.json ->
148
-
?unknown:Unknown.t ->
149
-
unit ->
150
-
output
151
-
(** {2 Response Builders} *)
92
+
(** {2 Conversion Functions} *)
152
93
153
-
val deny : ?reason:string -> ?unknown:Unknown.t -> unit -> output
154
-
val ask : ?reason:string -> ?unknown:Unknown.t -> unit -> output
155
-
val continue : ?unknown:Unknown.t -> unit -> output
94
+
val input_of_proto : Proto.Hooks.PreToolUse.Input.t -> input
95
+
(** [input_of_proto proto] converts wire format input to typed input. *)
156
96
157
-
val output_to_json : output -> Jsont.json
158
-
(** Convert output to JSON for hook_specific_output *)
97
+
val output_to_proto : output -> Proto.Hooks.PreToolUse.Output.t
98
+
(** [output_to_proto output] converts typed output to wire format. *)
159
99
end
160
100
161
101
(** PostToolUse hook - fires after tool execution *)
162
102
module PostToolUse : sig
103
+
(** {2 Input} *)
104
+
163
105
type input = {
164
106
session_id : string;
165
107
transcript_path : string;
166
108
tool_name : string;
167
-
tool_input : Jsont.json;
168
-
tool_response : Jsont.json;
169
-
unknown : Unknown.t;
109
+
tool_input : Tool_input.t;
110
+
tool_response : Jsont.json; (* Response varies by tool *)
170
111
}
112
+
(** Input provided to PostToolUse hooks.
113
+
Note: [tool_response] remains as {!Jsont.json} since response schemas
114
+
vary by tool. *)
171
115
172
-
type t = input
173
-
174
-
val of_json : Jsont.json -> t
175
-
val session_id : t -> string
176
-
val transcript_path : t -> string
177
-
val tool_name : t -> string
178
-
val tool_input : t -> Jsont.json
179
-
val tool_response : t -> Jsont.json
180
-
val unknown : t -> Unknown.t
181
-
val input_jsont : input Jsont.t
116
+
(** {2 Output} *)
182
117
183
118
type output = {
184
-
decision : decision option;
119
+
block : bool;
185
120
reason : string option;
186
121
additional_context : string option;
187
-
unknown : Unknown.t;
188
122
}
123
+
(** Output from PostToolUse hooks. *)
189
124
190
-
val output_jsont : output Jsont.t
125
+
(** {2 Response Builders} *)
191
126
192
-
val continue :
193
-
?additional_context:string -> ?unknown:Unknown.t -> unit -> output
127
+
val continue : ?additional_context:string -> unit -> output
128
+
(** [continue ?additional_context ()] creates a continue response.
129
+
@param additional_context Optional context to add to the transcript *)
194
130
195
131
val block :
196
-
?reason:string ->
197
-
?additional_context:string ->
198
-
?unknown:Unknown.t ->
199
-
unit ->
200
-
output
132
+
?reason:string -> ?additional_context:string -> unit -> output
133
+
(** [block ?reason ?additional_context ()] creates a block response.
134
+
@param reason Optional explanation for blocking
135
+
@param additional_context Optional context to add to the transcript *)
136
+
137
+
(** {2 Callback Type} *)
201
138
202
-
val output_to_json : output -> Jsont.json
139
+
type callback = input -> output
140
+
(** Callback function type for PostToolUse hooks. *)
141
+
142
+
(** {2 Conversion Functions} *)
143
+
144
+
val input_of_proto : Proto.Hooks.PostToolUse.Input.t -> input
145
+
(** [input_of_proto proto] converts wire format input to typed input. *)
146
+
147
+
val output_to_proto : output -> Proto.Hooks.PostToolUse.Output.t
148
+
(** [output_to_proto output] converts typed output to wire format. *)
203
149
end
204
150
205
151
(** UserPromptSubmit hook - fires when user submits a prompt *)
206
152
module UserPromptSubmit : sig
153
+
(** {2 Input} *)
154
+
207
155
type input = {
208
156
session_id : string;
209
157
transcript_path : string;
210
158
prompt : string;
211
-
unknown : Unknown.t;
212
159
}
213
-
214
-
type t = input
160
+
(** Input provided to UserPromptSubmit hooks. *)
215
161
216
-
val of_json : Jsont.json -> t
217
-
val session_id : t -> string
218
-
val transcript_path : t -> string
219
-
val prompt : t -> string
220
-
val unknown : t -> Unknown.t
221
-
val input_jsont : input Jsont.t
162
+
(** {2 Output} *)
222
163
223
164
type output = {
224
-
decision : decision option;
165
+
block : bool;
225
166
reason : string option;
226
167
additional_context : string option;
227
-
unknown : Unknown.t;
228
168
}
169
+
(** Output from UserPromptSubmit hooks. *)
229
170
230
-
val output_jsont : output Jsont.t
171
+
(** {2 Response Builders} *)
172
+
173
+
val continue : ?additional_context:string -> unit -> output
174
+
(** [continue ?additional_context ()] creates a continue response.
175
+
@param additional_context Optional context to add to the transcript *)
231
176
232
-
val continue :
233
-
?additional_context:string -> ?unknown:Unknown.t -> unit -> output
177
+
val block : ?reason:string -> unit -> output
178
+
(** [block ?reason ()] creates a block response.
179
+
@param reason Optional explanation for blocking *)
234
180
235
-
val block : ?reason:string -> ?unknown:Unknown.t -> unit -> output
236
-
val output_to_json : output -> Jsont.json
181
+
(** {2 Callback Type} *)
182
+
183
+
type callback = input -> output
184
+
(** Callback function type for UserPromptSubmit hooks. *)
185
+
186
+
(** {2 Conversion Functions} *)
187
+
188
+
val input_of_proto : Proto.Hooks.UserPromptSubmit.Input.t -> input
189
+
(** [input_of_proto proto] converts wire format input to typed input. *)
190
+
191
+
val output_to_proto : output -> Proto.Hooks.UserPromptSubmit.Output.t
192
+
(** [output_to_proto output] converts typed output to wire format. *)
237
193
end
238
194
239
195
(** Stop hook - fires when conversation stops *)
240
196
module Stop : sig
197
+
(** {2 Input} *)
198
+
241
199
type input = {
242
200
session_id : string;
243
201
transcript_path : string;
244
202
stop_hook_active : bool;
245
-
unknown : Unknown.t;
246
203
}
204
+
(** Input provided to Stop hooks. *)
247
205
248
-
type t = input
249
-
250
-
val of_json : Jsont.json -> t
251
-
val session_id : t -> string
252
-
val transcript_path : t -> string
253
-
val stop_hook_active : t -> bool
254
-
val unknown : t -> Unknown.t
255
-
val input_jsont : input Jsont.t
206
+
(** {2 Output} *)
256
207
257
208
type output = {
258
-
decision : decision option;
209
+
block : bool;
259
210
reason : string option;
260
-
unknown : Unknown.t;
261
211
}
212
+
(** Output from Stop hooks. *)
213
+
214
+
(** {2 Response Builders} *)
215
+
216
+
val continue : unit -> output
217
+
(** [continue ()] creates a continue response. *)
262
218
263
-
val output_jsont : output Jsont.t
264
-
val continue : ?unknown:Unknown.t -> unit -> output
265
-
val block : ?reason:string -> ?unknown:Unknown.t -> unit -> output
266
-
val output_to_json : output -> Jsont.json
219
+
val block : ?reason:string -> unit -> output
220
+
(** [block ?reason ()] creates a block response.
221
+
@param reason Optional explanation for blocking *)
222
+
223
+
(** {2 Callback Type} *)
224
+
225
+
type callback = input -> output
226
+
(** Callback function type for Stop hooks. *)
227
+
228
+
(** {2 Conversion Functions} *)
229
+
230
+
val input_of_proto : Proto.Hooks.Stop.Input.t -> input
231
+
(** [input_of_proto proto] converts wire format input to typed input. *)
232
+
233
+
val output_to_proto : output -> Proto.Hooks.Stop.Output.t
234
+
(** [output_to_proto output] converts typed output to wire format. *)
267
235
end
268
236
269
237
(** SubagentStop hook - fires when a subagent stops *)
270
238
module SubagentStop : sig
239
+
(** {2 Input} *)
240
+
271
241
type input = Stop.input
272
-
type t = input
242
+
(** Same structure as Stop.input *)
243
+
244
+
(** {2 Output} *)
245
+
273
246
type output = Stop.output
247
+
(** Same structure as Stop.output *)
274
248
275
-
val of_json : Jsont.json -> t
276
-
val session_id : t -> string
277
-
val transcript_path : t -> string
278
-
val stop_hook_active : t -> bool
279
-
val unknown : t -> Unknown.t
280
-
val input_jsont : input Jsont.t
281
-
val output_jsont : output Jsont.t
282
-
val continue : ?unknown:Unknown.t -> unit -> output
283
-
val block : ?reason:string -> ?unknown:Unknown.t -> unit -> output
284
-
val output_to_json : output -> Jsont.json
249
+
(** {2 Response Builders} *)
250
+
251
+
val continue : unit -> output
252
+
(** [continue ()] creates a continue response. *)
253
+
254
+
val block : ?reason:string -> unit -> output
255
+
(** [block ?reason ()] creates a block response.
256
+
@param reason Optional explanation for blocking *)
257
+
258
+
(** {2 Callback Type} *)
259
+
260
+
type callback = input -> output
261
+
(** Callback function type for SubagentStop hooks. *)
262
+
263
+
(** {2 Conversion Functions} *)
264
+
265
+
val input_of_proto : Proto.Hooks.SubagentStop.Input.t -> input
266
+
(** [input_of_proto proto] converts wire format input to typed input. *)
267
+
268
+
val output_to_proto : output -> Proto.Hooks.SubagentStop.Output.t
269
+
(** [output_to_proto output] converts typed output to wire format. *)
285
270
end
286
271
287
272
(** PreCompact hook - fires before message compaction *)
288
273
module PreCompact : sig
274
+
(** {2 Input} *)
275
+
289
276
type input = {
290
277
session_id : string;
291
278
transcript_path : string;
292
-
unknown : Unknown.t;
293
279
}
280
+
(** Input provided to PreCompact hooks. *)
294
281
295
-
type t = input
296
-
type output = unit
282
+
(** {2 Callback Type} *)
297
283
298
-
val of_json : Jsont.json -> t
299
-
val session_id : t -> string
300
-
val transcript_path : t -> string
301
-
val unknown : t -> Unknown.t
302
-
val input_jsont : input Jsont.t
303
-
val continue : unit -> output
304
-
val output_to_json : output -> Jsont.json
305
-
end
284
+
type callback = input -> unit
285
+
(** Callback function type for PreCompact hooks.
286
+
PreCompact hooks have no output - they are notification-only. *)
306
287
307
-
(** {1 Callbacks} *)
288
+
(** {2 Conversion Functions} *)
308
289
309
-
type callback =
310
-
input:Jsont.json -> tool_use_id:string option -> context:Context.t -> result
311
-
(** Generic callback function type.
290
+
val input_of_proto : Proto.Hooks.PreCompact.Input.t -> input
291
+
(** [input_of_proto proto] converts wire format input to typed input. *)
292
+
end
312
293
313
-
Callbacks receive:
314
-
- [input]: Raw JSON input (parse with [PreToolUse.of_json], etc.)
315
-
- [tool_use_id]: Optional tool use ID
316
-
- [context]: Hook context
294
+
(** {1 Hook Configuration} *)
317
295
318
-
And return a generic [result] with optional hook-specific output. *)
296
+
type t
297
+
(** Hook configuration.
319
298
320
-
(** {1 Matchers} *)
299
+
Hooks are configured using a builder pattern:
300
+
{[
301
+
Hooks.empty
302
+
|> Hooks.on_pre_tool_use ~pattern:"Bash" bash_handler
303
+
|> Hooks.on_post_tool_use post_handler
304
+
]} *)
321
305
322
-
type matcher = {
323
-
matcher : string option;
324
-
(** Pattern to match (e.g., "Bash" or "Write|Edit") *)
325
-
callbacks : callback list; (** Callbacks to invoke on match *)
326
-
}
327
-
(** A matcher configuration *)
306
+
val empty : t
307
+
(** [empty] is an empty hook configuration with no callbacks. *)
328
308
329
-
type config = (event * matcher list) list
330
-
(** Hook configuration: map from events to matchers *)
309
+
val on_pre_tool_use : ?pattern:string -> PreToolUse.callback -> t -> t
310
+
(** [on_pre_tool_use ?pattern callback config] adds a PreToolUse hook.
311
+
@param pattern Optional regex pattern to match tool names (e.g., "Bash|Edit")
312
+
@param callback Function to invoke on matching events *)
331
313
332
-
(** {1 Generic Result Builders} *)
314
+
val on_post_tool_use : ?pattern:string -> PostToolUse.callback -> t -> t
315
+
(** [on_post_tool_use ?pattern callback config] adds a PostToolUse hook.
316
+
@param pattern Optional regex pattern to match tool names
317
+
@param callback Function to invoke on matching events *)
333
318
334
-
val continue :
335
-
?system_message:string ->
336
-
?hook_specific_output:Jsont.json ->
337
-
?unknown:Unknown.t ->
338
-
unit ->
339
-
result
340
-
(** [continue ?system_message ?hook_specific_output ?unknown ()] creates a
341
-
continue result *)
319
+
val on_user_prompt_submit : UserPromptSubmit.callback -> t -> t
320
+
(** [on_user_prompt_submit callback config] adds a UserPromptSubmit hook.
321
+
@param callback Function to invoke on prompt submission *)
342
322
343
-
val block :
344
-
?system_message:string ->
345
-
?hook_specific_output:Jsont.json ->
346
-
?unknown:Unknown.t ->
347
-
unit ->
348
-
result
349
-
(** [block ?system_message ?hook_specific_output ?unknown ()] creates a block
350
-
result *)
323
+
val on_stop : Stop.callback -> t -> t
324
+
(** [on_stop callback config] adds a Stop hook.
325
+
@param callback Function to invoke on conversation stop *)
351
326
352
-
(** {1 Configuration Builders} *)
327
+
val on_subagent_stop : SubagentStop.callback -> t -> t
328
+
(** [on_subagent_stop callback config] adds a SubagentStop hook.
329
+
@param callback Function to invoke on subagent stop *)
353
330
354
-
val matcher : ?pattern:string -> callback list -> matcher
355
-
(** [matcher ?pattern callbacks] creates a matcher *)
331
+
val on_pre_compact : PreCompact.callback -> t -> t
332
+
(** [on_pre_compact callback config] adds a PreCompact hook.
333
+
@param callback Function to invoke before message compaction *)
356
334
357
-
val empty : config
358
-
(** Empty hooks configuration *)
335
+
(** {1 Internal - for client use} *)
359
336
360
-
val add : event -> matcher list -> config -> config
361
-
(** [add event matchers config] adds matchers for an event *)
337
+
val get_callbacks :
338
+
t ->
339
+
(Proto.Hooks.event * (string option * (Jsont.json -> Proto.Hooks.result))
340
+
list)
341
+
list
342
+
(** [get_callbacks config] returns hook configuration in format suitable for
343
+
registration with the CLI.
362
344
363
-
(** {1 JSON Serialization} *)
345
+
This function converts typed callbacks into wire format handlers that:
346
+
- Parse JSON input using Proto.Hooks types
347
+
- Convert to typed input using input_of_proto
348
+
- Invoke the user's typed callback
349
+
- Convert output back to wire format using output_to_proto
364
350
365
-
val result_to_json : result -> Jsont.json
366
-
val config_to_protocol_format : config -> Jsont.json
351
+
This is an internal function used by {!Client} - you should not need to
352
+
call it directly. *)
+6
-6
lib/incoming.ml
+6
-6
lib/incoming.ml
···
30
30
~dec:(fun v -> Control_response v)
31
31
in
32
32
let case_user =
33
-
Jsont.Object.Case.map "user" Message.User.incoming_jsont
34
-
~dec:(fun v -> Message (Message.User v))
33
+
Jsont.Object.Case.map "user" Message.User.incoming_jsont ~dec:(fun v ->
34
+
Message (Message.User v))
35
35
in
36
36
let case_assistant =
37
37
Jsont.Object.Case.map "assistant" Message.Assistant.incoming_jsont
38
38
~dec:(fun v -> Message (Message.Assistant v))
39
39
in
40
40
let case_system =
41
-
Jsont.Object.Case.map "system" Message.System.jsont
42
-
~dec:(fun v -> Message (Message.System v))
41
+
Jsont.Object.Case.map "system" Message.System.jsont ~dec:(fun v ->
42
+
Message (Message.System v))
43
43
in
44
44
let case_result =
45
-
Jsont.Object.Case.map "result" Message.Result.jsont
46
-
~dec:(fun v -> Message (Message.Result v))
45
+
Jsont.Object.Case.map "result" Message.Result.jsont ~dec:(fun v ->
46
+
Message (Message.Result v))
47
47
in
48
48
let enc_case = function
49
49
| Control_request v -> Jsont.Object.Case.value case_control_request v
+102
-576
lib/message.ml
+102
-576
lib/message.ml
···
3
3
module Log = (val Logs.src_log src : Logs.LOG)
4
4
5
5
module User = struct
6
-
type content = String of string | Blocks of Content_block.t list
7
-
type t = { content : content; unknown : Unknown.t }
6
+
type t = Proto.Message.User.t
8
7
9
-
let create_string s = { content = String s; unknown = Unknown.empty }
8
+
let of_string s = Proto.Message.User.create_string s
9
+
let of_blocks blocks = Proto.Message.User.create_blocks (List.map Content_block.to_proto blocks)
10
10
11
-
let create_blocks blocks =
12
-
{ content = Blocks blocks; unknown = Unknown.empty }
11
+
let with_tool_result ~tool_use_id ~content ?is_error () =
12
+
Proto.Message.User.create_with_tool_result ~tool_use_id ~content ?is_error ()
13
13
14
-
let create_with_tool_result ~tool_use_id ~content ?is_error () =
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 }
14
+
let as_text t =
15
+
match Proto.Message.User.content t with
16
+
| Proto.Message.User.String s -> Some s
17
+
| Proto.Message.User.Blocks _ -> None
19
18
20
-
let create_mixed ~text ~tool_results =
21
-
let blocks =
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
30
-
in
31
-
text_blocks @ tool_blocks
32
-
in
33
-
{ content = Blocks blocks; unknown = Unknown.empty }
34
-
35
-
let make content unknown = { content; unknown }
36
-
let content t = t.content
37
-
let unknown t = t.unknown
38
-
let as_text t = match t.content with String s -> Some s | Blocks _ -> None
39
-
40
-
let get_blocks t =
41
-
match t.content with
42
-
| String s -> [ Content_block.text s ]
43
-
| Blocks blocks -> blocks
44
-
45
-
(* Decode content from json value *)
46
-
let decode_content json =
47
-
match json with
48
-
| Jsont.String (s, _) -> String s
49
-
| Jsont.Array (items, _) ->
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
57
-
Blocks blocks
58
-
| _ -> failwith "Content must be string or array"
59
-
60
-
(* Encode content to json value *)
61
-
let encode_content = function
62
-
| String s -> Jsont.String (s, Jsont.Meta.none)
63
-
| Blocks blocks ->
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
71
-
Jsont.Array (jsons, Jsont.Meta.none)
72
-
73
-
let jsont : t Jsont.t =
74
-
Jsont.Object.map ~kind:"User" (fun json_content unknown ->
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))
79
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
80
-
|> Jsont.Object.finish
81
-
82
-
(** Wire-format codec for outgoing user messages.
83
-
Format: {"type": "user", "message": {"role": "user", "content": ...}} *)
84
-
module Wire = struct
85
-
type inner = { role : string; content : Jsont.json }
86
-
type outer = { type_ : string; message : inner }
19
+
let blocks t =
20
+
match Proto.Message.User.content t with
21
+
| Proto.Message.User.String s -> [ Content_block.text s ]
22
+
| Proto.Message.User.Blocks bs -> List.map Content_block.of_proto bs
87
23
88
-
let inner_jsont : inner Jsont.t =
89
-
let make role content = { role; content } in
90
-
Jsont.Object.map ~kind:"UserMessageInner" make
91
-
|> Jsont.Object.mem "role" Jsont.string ~enc:(fun r -> r.role)
92
-
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun r -> r.content)
93
-
|> Jsont.Object.finish
24
+
let of_proto proto = proto
25
+
let to_proto t = t
94
26
95
-
let outer_jsont : outer Jsont.t =
96
-
let make type_ message = { type_; message } in
97
-
Jsont.Object.map ~kind:"UserMessageOuter" make
98
-
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun r -> r.type_)
99
-
|> Jsont.Object.mem "message" inner_jsont ~enc:(fun r -> r.message)
100
-
|> Jsont.Object.finish
101
-
end
27
+
(* Internal wire format functions *)
28
+
let incoming_jsont = Proto.Message.User.incoming_jsont
102
29
103
30
let to_json t =
104
-
let content_json = encode_content t.content in
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: "
110
-
111
-
(* Jsont codec for parsing incoming user messages from CLI *)
112
-
let incoming_jsont : t Jsont.t =
113
-
let message_jsont =
114
-
Jsont.Object.map ~kind:"UserMessage" (fun json_content ->
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))
119
-
|> Jsont.Object.finish
120
-
in
121
-
Jsont.Object.map ~kind:"UserEnvelope" Fun.id
122
-
|> Jsont.Object.mem "message" message_jsont ~enc:Fun.id
123
-
|> Jsont.Object.finish
124
-
125
-
let of_json json =
126
-
Jsont.Json.decode incoming_jsont json |> Err.get_ok' ~msg:"User.of_json: "
31
+
match Jsont.Json.encode Proto.Message.User.jsont t with
32
+
| Ok json -> json
33
+
| Error e -> invalid_arg ("User.to_json: " ^ e)
127
34
end
128
35
129
36
module Assistant = struct
130
-
type error =
131
-
[ `Authentication_failed
132
-
| `Billing_error
133
-
| `Rate_limit
134
-
| `Invalid_request
135
-
| `Server_error
136
-
| `Unknown ]
37
+
type error = Proto.Message.Assistant.error
137
38
138
-
let error_to_string = function
139
-
| `Authentication_failed -> "authentication_failed"
140
-
| `Billing_error -> "billing_error"
141
-
| `Rate_limit -> "rate_limit"
142
-
| `Invalid_request -> "invalid_request"
143
-
| `Server_error -> "server_error"
144
-
| `Unknown -> "unknown"
39
+
type t = Proto.Message.Assistant.t
145
40
146
-
let error_of_string = function
147
-
| "authentication_failed" -> `Authentication_failed
148
-
| "billing_error" -> `Billing_error
149
-
| "rate_limit" -> `Rate_limit
150
-
| "invalid_request" -> `Invalid_request
151
-
| "server_error" -> `Server_error
152
-
| "unknown" | _ -> `Unknown
41
+
let content t = List.map Content_block.of_proto (Proto.Message.Assistant.content t)
42
+
let model t = Proto.Message.Assistant.model t
43
+
let error t = Proto.Message.Assistant.error t
153
44
154
-
let error_jsont : error Jsont.t =
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
-
]
164
-
165
-
type t = {
166
-
content : Content_block.t list;
167
-
model : string;
168
-
error : error option;
169
-
unknown : Unknown.t;
170
-
}
171
-
172
-
let create ~content ~model ?error () =
173
-
{ content; model; error; unknown = Unknown.empty }
174
-
175
-
let make content model error unknown = { content; model; error; unknown }
176
-
let content t = t.content
177
-
let model t = t.model
178
-
let error t = t.error
179
-
let unknown t = t.unknown
180
-
181
-
let get_text_blocks t =
45
+
let text_blocks t =
182
46
List.filter_map
183
47
(function
184
48
| Content_block.Text text -> Some (Content_block.Text.text text)
185
49
| _ -> None)
186
-
t.content
50
+
(content t)
187
51
188
-
let get_tool_uses t =
52
+
let tool_uses t =
189
53
List.filter_map
190
54
(function Content_block.Tool_use tool -> Some tool | _ -> None)
191
-
t.content
55
+
(content t)
192
56
193
-
let get_thinking t =
57
+
let thinking_blocks t =
194
58
List.filter_map
195
59
(function Content_block.Thinking thinking -> Some thinking | _ -> None)
196
-
t.content
60
+
(content t)
197
61
198
62
let has_tool_use t =
199
-
List.exists
200
-
(function Content_block.Tool_use _ -> true | _ -> false)
201
-
t.content
63
+
List.exists (function Content_block.Tool_use _ -> true | _ -> false) (content t)
202
64
203
-
let combined_text t = String.concat "\n" (get_text_blocks t)
65
+
let combined_text t = String.concat "\n" (text_blocks t)
204
66
205
-
let jsont : t Jsont.t =
206
-
Jsont.Object.map ~kind:"Assistant" make
207
-
|> Jsont.Object.mem "content" (Jsont.list Content_block.jsont) ~enc:content
208
-
|> Jsont.Object.mem "model" Jsont.string ~enc:model
209
-
|> Jsont.Object.opt_mem "error" error_jsont ~enc:error
210
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
211
-
|> Jsont.Object.finish
67
+
let of_proto proto = proto
68
+
let to_proto t = t
212
69
213
-
let encode_content_blocks blocks =
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
-
Jsont.Array (jsons, Jsont.Meta.none)
222
-
223
-
(** Wire-format codec for outgoing assistant messages. *)
224
-
module Wire = struct
225
-
type inner = {
226
-
wire_content : Jsont.json;
227
-
wire_model : string;
228
-
wire_error : string option;
229
-
}
230
-
231
-
type outer = { wire_type : string; wire_message : inner }
232
-
233
-
let inner_jsont : inner Jsont.t =
234
-
let make wire_content wire_model wire_error =
235
-
{ wire_content; wire_model; wire_error }
236
-
in
237
-
Jsont.Object.map ~kind:"AssistantMessageInner" make
238
-
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun r -> r.wire_content)
239
-
|> Jsont.Object.mem "model" Jsont.string ~enc:(fun r -> r.wire_model)
240
-
|> Jsont.Object.opt_mem "error" Jsont.string ~enc:(fun r -> r.wire_error)
241
-
|> Jsont.Object.finish
242
-
243
-
let outer_jsont : outer Jsont.t =
244
-
let make wire_type wire_message = { wire_type; wire_message } in
245
-
Jsont.Object.map ~kind:"AssistantMessageOuter" make
246
-
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun r -> r.wire_type)
247
-
|> Jsont.Object.mem "message" inner_jsont ~enc:(fun r -> r.wire_message)
248
-
|> Jsont.Object.finish
249
-
end
70
+
(* Internal wire format functions *)
71
+
let incoming_jsont = Proto.Message.Assistant.incoming_jsont
250
72
251
73
let to_json t =
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: "
266
-
267
-
(* Jsont codec for parsing incoming assistant messages from CLI *)
268
-
let incoming_jsont : t Jsont.t =
269
-
Jsont.Object.map ~kind:"AssistantEnvelope" Fun.id
270
-
|> Jsont.Object.mem "message" jsont ~enc:Fun.id
271
-
|> Jsont.Object.finish
272
-
273
-
let of_json json =
274
-
Jsont.Json.decode incoming_jsont json
275
-
|> Err.get_ok' ~msg:"Assistant.of_json: "
74
+
match Jsont.Json.encode Proto.Message.Assistant.jsont t with
75
+
| Ok json -> json
76
+
| Error e -> invalid_arg ("Assistant.to_json: " ^ e)
276
77
end
277
78
278
79
module System = struct
279
-
(** System messages as a discriminated union on "subtype" field *)
280
-
281
-
type init = {
282
-
session_id : string option;
283
-
model : string option;
284
-
cwd : string option;
285
-
unknown : Unknown.t;
286
-
}
287
-
288
-
type error = { error : string; unknown : Unknown.t }
289
-
type t = Init of init | Error of error
290
-
291
-
(* Accessors *)
292
-
let session_id = function Init i -> i.session_id | _ -> None
293
-
let model = function Init i -> i.model | _ -> None
294
-
let cwd = function Init i -> i.cwd | _ -> None
295
-
let error_msg = function Error e -> Some e.error | _ -> None
296
-
let subtype = function Init _ -> "init" | Error _ -> "error"
297
-
let unknown = function Init i -> i.unknown | Error e -> e.unknown
298
-
299
-
(* Constructors *)
300
-
let init ?session_id ?model ?cwd () =
301
-
Init { session_id; model; cwd; unknown = Unknown.empty }
80
+
type t = Proto.Message.System.t
302
81
303
-
let error ~error = Error { error; unknown = Unknown.empty }
304
-
305
-
(* Individual record codecs *)
306
-
let init_jsont : init Jsont.t =
307
-
let make session_id model cwd unknown : init =
308
-
{ session_id; model; cwd; unknown }
309
-
in
310
-
Jsont.Object.map ~kind:"SystemInit" make
311
-
|> Jsont.Object.opt_mem "session_id" Jsont.string ~enc:(fun (r : init) ->
312
-
r.session_id)
313
-
|> Jsont.Object.opt_mem "model" Jsont.string ~enc:(fun (r : init) ->
314
-
r.model)
315
-
|> Jsont.Object.opt_mem "cwd" Jsont.string ~enc:(fun (r : init) -> r.cwd)
316
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : init) ->
317
-
r.unknown)
318
-
|> Jsont.Object.finish
82
+
let is_init = function Proto.Message.System.Init _ -> true | _ -> false
83
+
let is_error = function Proto.Message.System.Error _ -> true | _ -> false
84
+
let session_id = Proto.Message.System.session_id
85
+
let model = Proto.Message.System.model
86
+
let cwd = Proto.Message.System.cwd
87
+
let error_message = Proto.Message.System.error_msg
319
88
320
-
let error_jsont : error Jsont.t =
321
-
let make err unknown : error = { error = err; unknown } in
322
-
Jsont.Object.map ~kind:"SystemError" make
323
-
|> Jsont.Object.mem "error" Jsont.string ~enc:(fun (r : error) -> r.error)
324
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : error) ->
325
-
r.unknown)
326
-
|> Jsont.Object.finish
89
+
let of_proto proto = proto
90
+
let to_proto t = t
327
91
328
-
(* Main codec using case_mem for "subtype" discriminator *)
329
-
let jsont : t Jsont.t =
330
-
let case_init =
331
-
Jsont.Object.Case.map "init" init_jsont ~dec:(fun v -> Init v)
332
-
in
333
-
let case_error =
334
-
Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
335
-
in
336
-
let enc_case = function
337
-
| Init v -> Jsont.Object.Case.value case_init v
338
-
| Error v -> Jsont.Object.Case.value case_error v
339
-
in
340
-
let cases = Jsont.Object.Case.[ make case_init; make case_error ] in
341
-
Jsont.Object.map ~kind:"System" Fun.id
342
-
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
343
-
~tag_to_string:Fun.id ~tag_compare:String.compare
344
-
|> Jsont.Object.finish
92
+
(* Internal wire format functions *)
93
+
let jsont = Proto.Message.System.jsont
345
94
346
95
let to_json t =
347
-
Jsont.Json.encode jsont t |> Err.get_ok ~msg:"System.to_json: "
348
-
349
-
let of_json json =
350
-
Jsont.Json.decode jsont json |> Err.get_ok' ~msg:"System.of_json: "
96
+
match Jsont.Json.encode Proto.Message.System.jsont t with
97
+
| Ok json -> json
98
+
| Error e -> invalid_arg ("System.to_json: " ^ e)
351
99
end
352
100
353
101
module Result = struct
354
102
module Usage = struct
355
-
type t = {
356
-
input_tokens : int option;
357
-
output_tokens : int option;
358
-
total_tokens : int option;
359
-
cache_creation_input_tokens : int option;
360
-
cache_read_input_tokens : int option;
361
-
unknown : Unknown.t;
362
-
}
103
+
type t = Proto.Message.Result.Usage.t
363
104
364
-
let make input_tokens output_tokens total_tokens cache_creation_input_tokens
365
-
cache_read_input_tokens unknown =
366
-
{
367
-
input_tokens;
368
-
output_tokens;
369
-
total_tokens;
370
-
cache_creation_input_tokens;
371
-
cache_read_input_tokens;
372
-
unknown;
373
-
}
105
+
let input_tokens = Proto.Message.Result.Usage.input_tokens
106
+
let output_tokens = Proto.Message.Result.Usage.output_tokens
107
+
let total_tokens = Proto.Message.Result.Usage.total_tokens
108
+
let cache_creation_input_tokens = Proto.Message.Result.Usage.cache_creation_input_tokens
109
+
let cache_read_input_tokens = Proto.Message.Result.Usage.cache_read_input_tokens
374
110
375
-
let create ?input_tokens ?output_tokens ?total_tokens
376
-
?cache_creation_input_tokens ?cache_read_input_tokens () =
377
-
{
378
-
input_tokens;
379
-
output_tokens;
380
-
total_tokens;
381
-
cache_creation_input_tokens;
382
-
cache_read_input_tokens;
383
-
unknown = Unknown.empty;
384
-
}
385
-
386
-
let input_tokens t = t.input_tokens
387
-
let output_tokens t = t.output_tokens
388
-
let total_tokens t = t.total_tokens
389
-
let cache_creation_input_tokens t = t.cache_creation_input_tokens
390
-
let cache_read_input_tokens t = t.cache_read_input_tokens
391
-
let unknown t = t.unknown
392
-
393
-
let jsont : t Jsont.t =
394
-
Jsont.Object.map ~kind:"Usage" make
395
-
|> Jsont.Object.opt_mem "input_tokens" Jsont.int ~enc:input_tokens
396
-
|> Jsont.Object.opt_mem "output_tokens" Jsont.int ~enc:output_tokens
397
-
|> Jsont.Object.opt_mem "total_tokens" Jsont.int ~enc:total_tokens
398
-
|> Jsont.Object.opt_mem "cache_creation_input_tokens" Jsont.int
399
-
~enc:cache_creation_input_tokens
400
-
|> Jsont.Object.opt_mem "cache_read_input_tokens" Jsont.int
401
-
~enc:cache_read_input_tokens
402
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
403
-
|> Jsont.Object.finish
404
-
405
-
let effective_input_tokens t =
406
-
match t.input_tokens with
407
-
| None -> 0
408
-
| Some input ->
409
-
let cached = Option.value t.cache_read_input_tokens ~default:0 in
410
-
max 0 (input - cached)
411
-
412
-
let total_cost_estimate t ~input_price ~output_price =
413
-
match (t.input_tokens, t.output_tokens) with
414
-
| Some input, Some output ->
415
-
let input_cost = float_of_int input *. input_price /. 1_000_000. in
416
-
let output_cost = float_of_int output *. output_price /. 1_000_000. in
417
-
Some (input_cost +. output_cost)
418
-
| _ -> None
111
+
let of_proto proto = proto
419
112
end
420
113
421
-
type t = {
422
-
subtype : string;
423
-
duration_ms : int;
424
-
duration_api_ms : int;
425
-
is_error : bool;
426
-
num_turns : int;
427
-
session_id : string;
428
-
total_cost_usd : float option;
429
-
usage : Usage.t option;
430
-
result : string option;
431
-
structured_output : Jsont.json option;
432
-
unknown : Unknown.t;
433
-
}
114
+
type t = Proto.Message.Result.t
434
115
435
-
let create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
436
-
~session_id ?total_cost_usd ?usage ?result ?structured_output () =
437
-
{
438
-
subtype;
439
-
duration_ms;
440
-
duration_api_ms;
441
-
is_error;
442
-
num_turns;
443
-
session_id;
444
-
total_cost_usd;
445
-
usage;
446
-
result;
447
-
structured_output;
448
-
unknown = Unknown.empty;
449
-
}
116
+
let duration_ms = Proto.Message.Result.duration_ms
117
+
let duration_api_ms = Proto.Message.Result.duration_api_ms
118
+
let is_error = Proto.Message.Result.is_error
119
+
let num_turns = Proto.Message.Result.num_turns
120
+
let session_id = Proto.Message.Result.session_id
121
+
let total_cost_usd = Proto.Message.Result.total_cost_usd
450
122
451
-
let make subtype duration_ms duration_api_ms is_error num_turns session_id
452
-
total_cost_usd usage result structured_output unknown =
453
-
{
454
-
subtype;
455
-
duration_ms;
456
-
duration_api_ms;
457
-
is_error;
458
-
num_turns;
459
-
session_id;
460
-
total_cost_usd;
461
-
usage;
462
-
result;
463
-
structured_output;
464
-
unknown;
465
-
}
123
+
let usage t = Option.map Usage.of_proto (Proto.Message.Result.usage t)
124
+
let result_text = Proto.Message.Result.result
125
+
let structured_output = Proto.Message.Result.structured_output
466
126
467
-
let subtype t = t.subtype
468
-
let duration_ms t = t.duration_ms
469
-
let duration_api_ms t = t.duration_api_ms
470
-
let is_error t = t.is_error
471
-
let num_turns t = t.num_turns
472
-
let session_id t = t.session_id
473
-
let total_cost_usd t = t.total_cost_usd
474
-
let usage t = t.usage
475
-
let result t = t.result
476
-
let structured_output t = t.structured_output
477
-
let unknown t = t.unknown
127
+
let of_proto proto = proto
128
+
let to_proto t = t
478
129
479
-
let jsont : t Jsont.t =
480
-
Jsont.Object.map ~kind:"Result" make
481
-
|> Jsont.Object.mem "subtype" Jsont.string ~enc:subtype
482
-
|> Jsont.Object.mem "duration_ms" Jsont.int ~enc:duration_ms
483
-
|> Jsont.Object.mem "duration_api_ms" Jsont.int ~enc:duration_api_ms
484
-
|> Jsont.Object.mem "is_error" Jsont.bool ~enc:is_error
485
-
|> Jsont.Object.mem "num_turns" Jsont.int ~enc:num_turns
486
-
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
487
-
|> Jsont.Object.opt_mem "total_cost_usd" Jsont.number ~enc:total_cost_usd
488
-
|> Jsont.Object.opt_mem "usage" Usage.jsont ~enc:usage
489
-
|> Jsont.Object.opt_mem "result" Jsont.string ~enc:result
490
-
|> Jsont.Object.opt_mem "structured_output" Jsont.json
491
-
~enc:structured_output
492
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
493
-
|> Jsont.Object.finish
494
-
495
-
(** Wire-format codec for outgoing result messages (adds "type" field). *)
496
-
module Wire = struct
497
-
type wire = {
498
-
type_ : string;
499
-
subtype : string;
500
-
duration_ms : int;
501
-
duration_api_ms : int;
502
-
is_error : bool;
503
-
num_turns : int;
504
-
session_id : string;
505
-
total_cost_usd : float option;
506
-
usage : Jsont.json option;
507
-
result : string option;
508
-
structured_output : Jsont.json option;
509
-
}
510
-
511
-
let jsont : wire Jsont.t =
512
-
let make type_ subtype duration_ms duration_api_ms is_error num_turns
513
-
session_id total_cost_usd usage result structured_output =
514
-
{
515
-
type_;
516
-
subtype;
517
-
duration_ms;
518
-
duration_api_ms;
519
-
is_error;
520
-
num_turns;
521
-
session_id;
522
-
total_cost_usd;
523
-
usage;
524
-
result;
525
-
structured_output;
526
-
}
527
-
in
528
-
Jsont.Object.map ~kind:"ResultWire" make
529
-
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun r -> r.type_)
530
-
|> Jsont.Object.mem "subtype" Jsont.string ~enc:(fun r -> r.subtype)
531
-
|> Jsont.Object.mem "duration_ms" Jsont.int ~enc:(fun r -> r.duration_ms)
532
-
|> Jsont.Object.mem "duration_api_ms" Jsont.int ~enc:(fun r ->
533
-
r.duration_api_ms)
534
-
|> Jsont.Object.mem "is_error" Jsont.bool ~enc:(fun r -> r.is_error)
535
-
|> Jsont.Object.mem "num_turns" Jsont.int ~enc:(fun r -> r.num_turns)
536
-
|> Jsont.Object.mem "session_id" Jsont.string ~enc:(fun r -> r.session_id)
537
-
|> Jsont.Object.opt_mem "total_cost_usd" Jsont.number ~enc:(fun r ->
538
-
r.total_cost_usd)
539
-
|> Jsont.Object.opt_mem "usage" Jsont.json ~enc:(fun r -> r.usage)
540
-
|> Jsont.Object.opt_mem "result" Jsont.string ~enc:(fun r -> r.result)
541
-
|> Jsont.Object.opt_mem "structured_output" Jsont.json ~enc:(fun r ->
542
-
r.structured_output)
543
-
|> Jsont.Object.finish
544
-
end
130
+
(* Internal wire format functions *)
131
+
let jsont = Proto.Message.Result.jsont
545
132
546
133
let to_json t =
547
-
let usage_json =
548
-
t.usage
549
-
|> Option.map (fun u ->
550
-
Jsont.Json.encode Usage.jsont u
551
-
|> Err.get_ok ~msg:"Result.to_json: usage: ")
552
-
in
553
-
let wire =
554
-
Wire.
555
-
{
556
-
type_ = "result";
557
-
subtype = t.subtype;
558
-
duration_ms = t.duration_ms;
559
-
duration_api_ms = t.duration_api_ms;
560
-
is_error = t.is_error;
561
-
num_turns = t.num_turns;
562
-
session_id = t.session_id;
563
-
total_cost_usd = t.total_cost_usd;
564
-
usage = usage_json;
565
-
result = t.result;
566
-
structured_output = t.structured_output;
567
-
}
568
-
in
569
-
Jsont.Json.encode Wire.jsont wire |> Err.get_ok ~msg:"Result.to_json: "
570
-
571
-
let of_json json =
572
-
Jsont.Json.decode jsont json |> Err.get_ok' ~msg:"Result.of_json: "
134
+
match Jsont.Json.encode Proto.Message.Result.jsont t with
135
+
| Ok json -> json
136
+
| Error e -> invalid_arg ("Result.to_json: " ^ e)
573
137
end
574
138
575
139
type t =
···
578
142
| System of System.t
579
143
| Result of Result.t
580
144
581
-
let user_string s = User (User.create_string s)
582
-
let user_blocks blocks = User (User.create_blocks blocks)
583
-
584
-
let user_with_tool_result ~tool_use_id ~content ?is_error () =
585
-
User (User.create_with_tool_result ~tool_use_id ~content ?is_error ())
586
-
587
-
let assistant ~content ~model ?error () =
588
-
Assistant (Assistant.create ~content ~model ?error ())
589
-
590
-
let assistant_text ~text ~model ?error () =
591
-
Assistant
592
-
(Assistant.create ~content:[ Content_block.text text ] ~model ?error ())
593
-
594
-
let system_init ~session_id = System (System.init ~session_id ())
595
-
let system_error ~error = System (System.error ~error)
596
-
597
-
let result ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
598
-
~session_id ?total_cost_usd ?usage ?result ?structured_output () =
599
-
Result
600
-
(Result.create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
601
-
~session_id ?total_cost_usd ?usage ?result ?structured_output ())
602
-
603
-
let to_json = function
604
-
| User t -> User.to_json t
605
-
| Assistant t -> Assistant.to_json t
606
-
| System t -> System.to_json t
607
-
| Result t -> Result.to_json t
608
-
609
-
(* Jsont codec for the main Message variant type.
610
-
Uses case_mem for discriminated union based on "type" field. *)
611
-
let jsont : t Jsont.t =
612
-
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
613
-
let case_user = case_map "user" User.incoming_jsont (fun v -> User v) in
614
-
let case_assistant =
615
-
case_map "assistant" Assistant.incoming_jsont (fun v -> Assistant v)
616
-
in
617
-
let case_system = case_map "system" System.jsont (fun v -> System v) in
618
-
let case_result = case_map "result" Result.jsont (fun v -> Result v) in
619
-
let enc_case = function
620
-
| User v -> Jsont.Object.Case.value case_user v
621
-
| Assistant v -> Jsont.Object.Case.value case_assistant v
622
-
| System v -> Jsont.Object.Case.value case_system v
623
-
| Result v -> Jsont.Object.Case.value case_result v
624
-
in
625
-
let cases =
626
-
Jsont.Object.Case.
627
-
[
628
-
make case_user; make case_assistant; make case_system; make case_result;
629
-
]
630
-
in
631
-
Jsont.Object.map ~kind:"Message" Fun.id
632
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
633
-
~tag_to_string:Fun.id ~tag_compare:String.compare
634
-
|> Jsont.Object.finish
145
+
let of_proto = function
146
+
| Proto.Message.User u -> User (User.of_proto u)
147
+
| Proto.Message.Assistant a -> Assistant (Assistant.of_proto a)
148
+
| Proto.Message.System s -> System (System.of_proto s)
149
+
| Proto.Message.Result r -> Result (Result.of_proto r)
635
150
636
-
let of_json json =
637
-
Jsont.Json.decode jsont json |> Err.get_ok' ~msg:"Message.of_json: "
151
+
let to_proto = function
152
+
| User u -> Proto.Message.User (User.to_proto u)
153
+
| Assistant a -> Proto.Message.Assistant (Assistant.to_proto a)
154
+
| System s -> Proto.Message.System (System.to_proto s)
155
+
| Result r -> Proto.Message.Result (Result.to_proto r)
638
156
639
157
let is_user = function User _ -> true | _ -> false
640
158
let is_assistant = function Assistant _ -> true | _ -> false
···
643
161
644
162
let is_error = function
645
163
| Result r -> Result.is_error r
646
-
| System (System.Error _) -> true
164
+
| System s -> System.is_error s
647
165
| _ -> false
648
166
649
167
let extract_text = function
···
653
171
if text = "" then None else Some text
654
172
| _ -> None
655
173
656
-
let extract_tool_uses = function
657
-
| Assistant a -> Assistant.get_tool_uses a
658
-
| _ -> []
174
+
let extract_tool_uses = function Assistant a -> Assistant.tool_uses a | _ -> []
659
175
660
176
let get_session_id = function
661
177
| System s -> System.session_id s
662
178
| Result r -> Some (Result.session_id r)
663
179
| _ -> None
664
180
665
-
let pp = Jsont.pp_value jsont ()
181
+
(* Wire format conversion *)
182
+
let to_json = function
183
+
| User u -> User.to_json u
184
+
| Assistant a -> Assistant.to_json a
185
+
| System s -> System.to_json s
186
+
| Result r -> Result.to_json r
187
+
188
+
(* Convenience constructors *)
189
+
let user_string s = User (User.of_string s)
190
+
let user_blocks blocks = User (User.of_blocks blocks)
191
+
192
+
let pp fmt t = Jsont.pp_value Proto.Message.jsont () fmt (to_proto t)
666
193
let log_received t = Log.info (fun m -> m "ā %a" pp t)
667
194
let log_sending t = Log.info (fun m -> m "ā %a" pp t)
668
-
let log_error msg t = Log.err (fun m -> m "%s: %a" msg pp t)
+99
-246
lib/message.mli
+99
-246
lib/message.mli
···
1
-
(** Messages exchanged with Claude.
1
+
(** Messages exchanged with Claude. Opaque types.
2
2
3
-
This module defines the various types of messages that can be sent to and
4
-
received from Claude, including user input, assistant responses, system
5
-
messages, and result metadata. *)
3
+
This module provides opaque message types that wrap the proto types but hide
4
+
the unknown fields and wire format details from the public API. *)
6
5
7
6
val src : Logs.Src.t
8
7
(** The log source for message operations *)
···
12
11
module User : sig
13
12
(** Messages sent by the user. *)
14
13
15
-
(** The content of a user message. *)
16
-
type content =
17
-
| String of string (** Simple text message *)
18
-
| Blocks of Content_block.t list
19
-
(** Complex message with multiple content blocks *)
20
-
21
14
type t
22
-
(** The type of user messages. *)
15
+
(** The type of user messages (opaque). *)
23
16
24
-
val jsont : t Jsont.t
25
-
(** [jsont] is the Jsont codec for user messages. *)
17
+
val of_string : string -> t
18
+
(** [of_string s] creates a user message with simple text content. *)
26
19
27
-
val incoming_jsont : t Jsont.t
28
-
(** [incoming_jsont] is the codec for parsing incoming user messages from CLI.
29
-
This parses the envelope format with "message" wrapper. *)
20
+
val of_blocks : Content_block.t list -> t
21
+
(** [of_blocks blocks] creates a user message with content blocks. *)
30
22
31
-
val create_string : string -> t
32
-
(** [create_string s] creates a user message with simple text content. *)
23
+
val with_tool_result :
24
+
tool_use_id:string -> content:string -> ?is_error:bool -> unit -> t
25
+
(** [with_tool_result ~tool_use_id ~content ?is_error ()] creates a user
26
+
message containing a tool result. *)
33
27
34
-
val create_blocks : Content_block.t list -> t
35
-
(** [create_blocks blocks] creates a user message with content blocks. *)
28
+
val as_text : t -> string option
29
+
(** [as_text t] returns the text content if the message is a simple string,
30
+
None otherwise. *)
36
31
37
-
val create_with_tool_result :
38
-
tool_use_id:string -> content:string -> ?is_error:bool -> unit -> t
39
-
(** [create_with_tool_result ~tool_use_id ~content ?is_error ()] creates a
40
-
user message containing a tool result. *)
32
+
val blocks : t -> Content_block.t list
33
+
(** [blocks t] returns the content blocks, or a single text block if it's a
34
+
string message. *)
41
35
42
-
val create_mixed :
43
-
text:string option -> tool_results:(string * string * bool option) list -> t
44
-
(** [create_mixed ?text ~tool_results] creates a user message with optional
45
-
text and tool results. Each tool result is (tool_use_id, content,
46
-
is_error). *)
36
+
(** {1 Internal - for lib use only} *)
47
37
48
-
val content : t -> content
49
-
(** [content t] returns the content of the user message. *)
50
-
51
-
val unknown : t -> Unknown.t
52
-
(** [unknown t] returns the unknown fields preserved from JSON. *)
38
+
val of_proto : Proto.Message.User.t -> t
39
+
(** [of_proto proto] wraps a proto user message. *)
53
40
54
-
val as_text : t -> string option
55
-
(** [as_text t] returns the text content if the message is a simple string,
56
-
None otherwise. *)
41
+
val to_proto : t -> Proto.Message.User.t
42
+
(** [to_proto t] extracts the proto user message. *)
57
43
58
-
val get_blocks : t -> Content_block.t list
59
-
(** [get_blocks t] returns the content blocks, or a single text block if it's
60
-
a string message. *)
44
+
val incoming_jsont : t Jsont.t
45
+
(** Internal codec for parsing incoming messages. *)
61
46
62
47
val to_json : t -> Jsont.json
63
-
(** [to_json t] converts the user message to its JSON representation. *)
64
-
65
-
val of_json : Jsont.json -> t
66
-
(** [of_json json] parses a user message from JSON.
67
-
@raise Invalid_argument if the JSON is not a valid user message. *)
48
+
(** Internal conversion to JSON for wire format. *)
68
49
end
69
50
70
51
(** {1 Assistant Messages} *)
···
81
62
| `Unknown (** Unknown error type *) ]
82
63
(** The type of assistant message errors based on Python SDK error types. *)
83
64
84
-
val error_to_string : error -> string
85
-
(** [error_to_string err] converts an error to its string representation. *)
86
-
87
-
val error_of_string : string -> error
88
-
(** [error_of_string s] parses an error string. Unknown strings become
89
-
[`Unknown]. *)
90
-
91
65
type t
92
-
(** The type of assistant messages. *)
93
-
94
-
val jsont : t Jsont.t
95
-
(** [jsont] is the Jsont codec for assistant messages. *)
96
-
97
-
val incoming_jsont : t Jsont.t
98
-
(** [incoming_jsont] is the codec for parsing incoming assistant messages from
99
-
CLI. This parses the envelope format with "message" wrapper. *)
100
-
101
-
val create :
102
-
content:Content_block.t list -> model:string -> ?error:error -> unit -> t
103
-
(** [create ~content ~model ?error ()] creates an assistant message.
104
-
@param content List of content blocks in the response
105
-
@param model The model identifier used for the response
106
-
@param error Optional error that occurred during message generation *)
66
+
(** The type of assistant messages (opaque). *)
107
67
108
68
val content : t -> Content_block.t list
109
69
(** [content t] returns the content blocks of the assistant message. *)
···
115
75
(** [error t] returns the optional error that occurred during message
116
76
generation. *)
117
77
118
-
val unknown : t -> Unknown.t
119
-
(** [unknown t] returns the unknown fields preserved from JSON. *)
78
+
(** {2 Convenience accessors} *)
120
79
121
-
val get_text_blocks : t -> string list
122
-
(** [get_text_blocks t] extracts all text content from the message. *)
80
+
val text_blocks : t -> string list
81
+
(** [text_blocks t] extracts all text content from the message. *)
82
+
83
+
val tool_uses : t -> Content_block.Tool_use.t list
84
+
(** [tool_uses t] extracts all tool use blocks from the message. *)
123
85
124
-
val get_tool_uses : t -> Content_block.Tool_use.t list
125
-
(** [get_tool_uses t] extracts all tool use blocks from the message. *)
86
+
val thinking_blocks : t -> Content_block.Thinking.t list
87
+
(** [thinking_blocks t] extracts all thinking blocks from the message. *)
126
88
127
-
val get_thinking : t -> Content_block.Thinking.t list
128
-
(** [get_thinking t] extracts all thinking blocks from the message. *)
89
+
val combined_text : t -> string
90
+
(** [combined_text t] concatenates all text blocks into a single string. *)
129
91
130
92
val has_tool_use : t -> bool
131
93
(** [has_tool_use t] returns true if the message contains any tool use blocks.
132
94
*)
133
95
134
-
val combined_text : t -> string
135
-
(** [combined_text t] concatenates all text blocks into a single string. *)
96
+
(** {1 Internal - for lib use only} *)
97
+
98
+
val of_proto : Proto.Message.Assistant.t -> t
99
+
(** [of_proto proto] wraps a proto assistant message. *)
100
+
101
+
val to_proto : t -> Proto.Message.Assistant.t
102
+
(** [to_proto t] extracts the proto assistant message. *)
103
+
104
+
val incoming_jsont : t Jsont.t
105
+
(** Internal codec for parsing incoming messages. *)
136
106
137
107
val to_json : t -> Jsont.json
138
-
(** [to_json t] converts the assistant message to its JSON representation. *)
139
-
140
-
val of_json : Jsont.json -> t
141
-
(** [of_json json] parses an assistant message from JSON.
142
-
@raise Invalid_argument if the JSON is not a valid assistant message. *)
108
+
(** Internal conversion to JSON for wire format. *)
143
109
end
144
110
145
111
(** {1 System Messages} *)
146
112
147
113
module System : sig
148
-
(** System control and status messages.
149
-
150
-
System messages use a discriminated union on the "subtype" field:
151
-
- "init": Session initialization with session_id, model, cwd
152
-
- "error": Error messages with error string *)
114
+
(** System control and status messages. *)
153
115
154
-
type init = {
155
-
session_id : string option;
156
-
model : string option;
157
-
cwd : string option;
158
-
unknown : Unknown.t;
159
-
}
160
-
(** Init message fields. *)
116
+
type t
117
+
(** The type of system messages (opaque). *)
161
118
162
-
type error = { error : string; unknown : Unknown.t }
163
-
(** Error message fields. *)
119
+
val is_init : t -> bool
120
+
(** [is_init t] returns true if the message is an init message. *)
164
121
165
-
type t = Init of init | Error of error
166
-
167
-
val jsont : t Jsont.t
168
-
(** [jsont] is the Jsont codec for system messages. *)
169
-
170
-
(** {2 Constructors} *)
171
-
172
-
val init : ?session_id:string -> ?model:string -> ?cwd:string -> unit -> t
173
-
(** [init ?session_id ?model ?cwd ()] creates an init message. *)
174
-
175
-
val error : error:string -> t
176
-
(** [error ~error] creates an error message. *)
177
-
178
-
(** {2 Accessors} *)
122
+
val is_error : t -> bool
123
+
(** [is_error t] returns true if the message is an error message. *)
179
124
180
125
val session_id : t -> string option
181
126
(** [session_id t] returns session_id from Init, None otherwise. *)
···
186
131
val cwd : t -> string option
187
132
(** [cwd t] returns cwd from Init, None otherwise. *)
188
133
189
-
val error_msg : t -> string option
190
-
(** [error_msg t] returns error from Error, None otherwise. *)
134
+
val error_message : t -> string option
135
+
(** [error_message t] returns error from Error, None otherwise. *)
191
136
192
-
val subtype : t -> string
193
-
(** [subtype t] returns the subtype string. *)
137
+
(** {1 Internal - for lib use only} *)
138
+
139
+
val of_proto : Proto.Message.System.t -> t
140
+
(** [of_proto proto] wraps a proto system message. *)
194
141
195
-
val unknown : t -> Unknown.t
196
-
(** [unknown t] returns the unknown fields. *)
142
+
val to_proto : t -> Proto.Message.System.t
143
+
(** [to_proto t] extracts the proto system message. *)
197
144
198
-
(** {2 Conversion} *)
145
+
val jsont : t Jsont.t
146
+
(** Internal codec for wire format. *)
199
147
200
148
val to_json : t -> Jsont.json
201
-
(** [to_json t] converts to JSON representation. *)
202
-
203
-
val of_json : Jsont.json -> t
204
-
(** [of_json json] parses from JSON.
205
-
@raise Invalid_argument if invalid. *)
149
+
(** Internal conversion to JSON for wire format. *)
206
150
end
207
151
208
152
(** {1 Result Messages} *)
···
214
158
(** Usage statistics for API calls. *)
215
159
216
160
type t
217
-
(** Type for usage statistics. *)
218
-
219
-
val jsont : t Jsont.t
220
-
(** [jsont] is the Jsont codec for usage statistics. *)
221
-
222
-
val create :
223
-
?input_tokens:int ->
224
-
?output_tokens:int ->
225
-
?total_tokens:int ->
226
-
?cache_creation_input_tokens:int ->
227
-
?cache_read_input_tokens:int ->
228
-
unit ->
229
-
t
230
-
(** [create ?input_tokens ?output_tokens ?total_tokens
231
-
?cache_creation_input_tokens ?cache_read_input_tokens ()] creates usage
232
-
statistics. *)
161
+
(** Type for usage statistics (opaque). *)
233
162
234
163
val input_tokens : t -> int option
235
164
(** [input_tokens t] returns the number of input tokens used. *)
···
246
175
val cache_read_input_tokens : t -> int option
247
176
(** [cache_read_input_tokens t] returns cache read input tokens. *)
248
177
249
-
val unknown : t -> Unknown.t
250
-
(** [unknown t] returns the unknown fields preserved from JSON. *)
178
+
(** {1 Internal - for lib use only} *)
251
179
252
-
val effective_input_tokens : t -> int
253
-
(** [effective_input_tokens t] returns input tokens minus cached tokens, or
254
-
0 if not available. *)
255
-
256
-
val total_cost_estimate :
257
-
t -> input_price:float -> output_price:float -> float option
258
-
(** [total_cost_estimate t ~input_price ~output_price] estimates the cost
259
-
based on token prices per million tokens. Returns None if token counts
260
-
are not available. *)
180
+
val of_proto : Proto.Message.Result.Usage.t -> t
181
+
(** [of_proto proto] wraps a proto usage object. *)
261
182
end
262
183
263
184
type t
264
-
(** The type of result messages. *)
265
-
266
-
val jsont : t Jsont.t
267
-
(** [jsont] is the Jsont codec for result messages. *)
268
-
269
-
val create :
270
-
subtype:string ->
271
-
duration_ms:int ->
272
-
duration_api_ms:int ->
273
-
is_error:bool ->
274
-
num_turns:int ->
275
-
session_id:string ->
276
-
?total_cost_usd:float ->
277
-
?usage:Usage.t ->
278
-
?result:string ->
279
-
?structured_output:Jsont.json ->
280
-
unit ->
281
-
t
282
-
(** [create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
283
-
~session_id ?total_cost_usd ?usage ?result ()] creates a result message.
284
-
@param subtype The subtype of the result
285
-
@param duration_ms Total duration in milliseconds
286
-
@param duration_api_ms API duration in milliseconds
287
-
@param is_error Whether the result represents an error
288
-
@param num_turns Number of conversation turns
289
-
@param session_id Unique session identifier
290
-
@param total_cost_usd Optional total cost in USD
291
-
@param usage Optional usage statistics as JSON
292
-
@param result Optional result string
293
-
@param structured_output Optional structured JSON output from Claude *)
294
-
295
-
val subtype : t -> string
296
-
(** [subtype t] returns the subtype of the result. *)
185
+
(** The type of result messages (opaque). *)
297
186
298
187
val duration_ms : t -> int
299
188
(** [duration_ms t] returns the total duration in milliseconds. *)
···
316
205
val usage : t -> Usage.t option
317
206
(** [usage t] returns the optional usage statistics. *)
318
207
319
-
val result : t -> string option
320
-
(** [result t] returns the optional result string. *)
208
+
val result_text : t -> string option
209
+
(** [result_text t] returns the optional result string. *)
321
210
322
211
val structured_output : t -> Jsont.json option
323
212
(** [structured_output t] returns the optional structured JSON output. *)
324
213
325
-
val unknown : t -> Unknown.t
326
-
(** [unknown t] returns the unknown fields preserved from JSON. *)
214
+
(** {1 Internal - for lib use only} *)
327
215
328
-
val to_json : t -> Jsont.json
329
-
(** [to_json t] converts the result message to its JSON representation. *)
216
+
val of_proto : Proto.Message.Result.t -> t
217
+
(** [of_proto proto] wraps a proto result message. *)
218
+
219
+
val to_proto : t -> Proto.Message.Result.t
220
+
(** [to_proto t] extracts the proto result message. *)
330
221
331
-
val of_json : Jsont.json -> t
332
-
(** [of_json json] parses a result message from JSON.
333
-
@raise Invalid_argument if the JSON is not a valid result message. *)
222
+
val jsont : t Jsont.t
223
+
(** Internal codec for wire format. *)
224
+
225
+
val to_json : t -> Jsont.json
226
+
(** Internal conversion to JSON for wire format. *)
334
227
end
335
228
336
229
(** {1 Message Union Type} *)
···
343
236
(** The type of messages, which can be user, assistant, system, or result.
344
237
*)
345
238
346
-
val jsont : t Jsont.t
347
-
(** [jsont] is the Jsont codec for messages. *)
348
-
349
-
val user_string : string -> t
350
-
(** [user_string s] creates a user message with text content. *)
351
-
352
-
val user_blocks : Content_block.t list -> t
353
-
(** [user_blocks blocks] creates a user message with content blocks. *)
354
-
355
-
val user_with_tool_result :
356
-
tool_use_id:string -> content:string -> ?is_error:bool -> unit -> t
357
-
(** [user_with_tool_result ~tool_use_id ~content ?is_error ()] creates a user
358
-
message containing a tool result. *)
359
-
360
-
val assistant :
361
-
content:Content_block.t list ->
362
-
model:string ->
363
-
?error:Assistant.error ->
364
-
unit ->
365
-
t
366
-
(** [assistant ~content ~model ?error ()] creates an assistant message. *)
367
-
368
-
val assistant_text :
369
-
text:string -> model:string -> ?error:Assistant.error -> unit -> t
370
-
(** [assistant_text ~text ~model ?error ()] creates an assistant message with
371
-
only text content. *)
372
-
373
-
val system_init : session_id:string -> t
374
-
(** [system_init ~session_id] creates a system init message. *)
239
+
val of_proto : Proto.Message.t -> t
240
+
(** [of_proto proto] converts a proto message to a lib message. *)
375
241
376
-
val system_error : error:string -> t
377
-
(** [system_error ~error] creates a system error message. *)
242
+
val to_proto : t -> Proto.Message.t
243
+
(** [to_proto t] converts a lib message to a proto message. *)
378
244
379
-
val result :
380
-
subtype:string ->
381
-
duration_ms:int ->
382
-
duration_api_ms:int ->
383
-
is_error:bool ->
384
-
num_turns:int ->
385
-
session_id:string ->
386
-
?total_cost_usd:float ->
387
-
?usage:Result.Usage.t ->
388
-
?result:string ->
389
-
?structured_output:Jsont.json ->
390
-
unit ->
391
-
t
392
-
(** [result ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
393
-
~session_id ?total_cost_usd ?usage ?result ()] creates a result message. *)
245
+
(** {1 Internal - wire format conversion} *)
394
246
395
247
val to_json : t -> Jsont.json
396
-
(** [to_json t] converts any message to its JSON representation. *)
248
+
(** [to_json t] converts any message to its JSON wire format representation. *)
397
249
398
-
val of_json : Jsont.json -> t
399
-
(** [of_json json] parses a message from JSON.
400
-
@raise Invalid_argument if the JSON is not a valid message. *)
250
+
(** {1 Convenience Constructors} *)
251
+
252
+
val user_string : string -> t
253
+
(** [user_string s] creates a user message with text content. *)
401
254
402
-
val pp : Format.formatter -> t -> unit
403
-
(** [pp fmt t] pretty-prints any message. *)
255
+
val user_blocks : Content_block.t list -> t
256
+
(** [user_blocks blocks] creates a user message with content blocks. *)
404
257
405
258
(** {1 Message Analysis} *)
406
259
···
431
284
432
285
(** {1 Logging} *)
433
286
287
+
val pp : Format.formatter -> t -> unit
288
+
(** [pp fmt t] pretty-prints any message. *)
289
+
434
290
val log_received : t -> unit
435
291
(** [log_received t] logs that a message was received. *)
436
292
437
293
val log_sending : t -> unit
438
294
(** [log_sending t] logs that a message is being sent. *)
439
-
440
-
val log_error : string -> t -> unit
441
-
(** [log_error msg t] logs an error with the given message and context. *)
+109
-131
lib/options.ml
+109
-131
lib/options.ml
···
1
-
let src = Logs.Src.create "claude.options" ~doc:"Claude configuration options"
1
+
let src = Logs.Src.create "claudeio.options" ~doc:"Claude configuration options"
2
2
3
3
module Log = (val Logs.src_log src : Logs.LOG)
4
-
5
-
type setting_source = User | Project | Local
6
4
7
5
type t = {
8
6
allowed_tools : string list;
···
12
10
append_system_prompt : string option;
13
11
permission_mode : Permissions.Mode.t option;
14
12
permission_callback : Permissions.callback option;
15
-
model : Model.t option;
13
+
model : Proto.Model.t option;
16
14
cwd : Eio.Fs.dir_ty Eio.Path.t option;
17
15
env : (string * string) list;
18
16
continue_conversation : bool;
···
23
21
add_dirs : string list;
24
22
extra_args : (string * string option) list;
25
23
debug_stderr : Eio.Flow.sink_ty Eio.Flow.sink option;
26
-
hooks : Hooks.config option;
24
+
hooks : Hooks.t option;
27
25
max_budget_usd : float option;
28
-
fallback_model : Model.t option;
29
-
setting_sources : setting_source list option;
26
+
fallback_model : Proto.Model.t option;
27
+
setting_sources : Proto.Options.setting_source list option;
30
28
max_buffer_size : int option;
31
29
user : string option;
32
-
output_format : Structured_output.t option;
33
-
unknown : Unknown.t;
30
+
output_format : Proto.Structured_output.t option;
34
31
}
35
32
36
33
let default =
···
41
38
system_prompt = None;
42
39
append_system_prompt = None;
43
40
permission_mode = None;
44
-
permission_callback = Some Permissions.default_allow_callback;
41
+
permission_callback = Some Permissions.default_allow;
45
42
model = None;
46
43
cwd = None;
47
44
env = [];
···
60
57
max_buffer_size = None;
61
58
user = None;
62
59
output_format = None;
63
-
unknown = Unknown.empty;
64
60
}
65
61
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
-
}
101
-
62
+
(* Accessors *)
102
63
let allowed_tools t = t.allowed_tools
103
64
let disallowed_tools t = t.disallowed_tools
104
65
let max_thinking_tokens t = t.max_thinking_tokens
···
124
85
let max_buffer_size t = t.max_buffer_size
125
86
let user t = t.user
126
87
let output_format t = t.output_format
127
-
let unknown t = t.unknown
88
+
89
+
(* Builders *)
128
90
let with_allowed_tools tools t = { t with allowed_tools = tools }
129
91
let with_disallowed_tools tools t = { t with disallowed_tools = tools }
130
92
let with_max_thinking_tokens tokens t = { t with max_thinking_tokens = tokens }
···
139
101
{ t with permission_callback = Some callback }
140
102
141
103
let with_model model t = { t with model = Some model }
142
-
let with_model_string model t = { t with model = Some (Model.of_string model) }
143
-
let with_cwd cwd t = { t with cwd = Some cwd }
104
+
let with_cwd cwd t = { t with cwd = Some (cwd :> Eio.Fs.dir_ty Eio.Path.t) }
144
105
let with_env env t = { t with env }
145
106
146
107
let with_continue_conversation continue t =
···
155
116
let with_settings path t = { t with settings = Some path }
156
117
let with_add_dirs dirs t = { t with add_dirs = dirs }
157
118
let with_extra_args args t = { t with extra_args = args }
158
-
let with_debug_stderr sink t = { t with debug_stderr = Some sink }
119
+
let with_debug_stderr sink t = { t with debug_stderr = Some (sink :> Eio.Flow.sink_ty Eio.Flow.sink) }
159
120
let with_hooks hooks t = { t with hooks = Some hooks }
160
121
let with_max_budget_usd budget t = { t with max_budget_usd = Some budget }
161
122
let with_fallback_model model t = { t with fallback_model = Some model }
162
123
163
-
let with_fallback_model_string model t =
164
-
{ t with fallback_model = Some (Model.of_string model) }
124
+
let with_no_settings t = { t with setting_sources = Some [] }
165
125
166
-
let with_setting_sources sources t = { t with setting_sources = Some sources }
167
-
let with_no_settings t = { t with setting_sources = Some [] }
168
126
let with_max_buffer_size size t = { t with max_buffer_size = Some size }
169
127
let with_user user t = { t with user = Some user }
170
128
let with_output_format format t = { t with output_format = Some format }
171
129
172
-
(* Helper codec for Model.t *)
173
-
let model_jsont : Model.t Jsont.t =
174
-
Jsont.map ~kind:"Model" ~dec:Model.of_string ~enc:Model.to_string Jsont.string
175
-
176
-
(* Helper codec for env - list of string pairs encoded as object.
177
-
Env is a dynamic object where all values should be strings.
178
-
Uses pattern matching to extract object members, then jsont for string decoding. *)
179
-
let env_jsont : (string * string) list Jsont.t =
180
-
Jsont.map ~kind:"Env"
181
-
~dec:(fun json ->
182
-
match json with
183
-
| Jsont.Object (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
190
-
| _ -> [])
191
-
~enc:(fun 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))
197
-
Jsont.json
198
-
199
-
let jsont : t Jsont.t =
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;
209
-
permission_callback = Some Permissions.default_allow_callback;
210
-
model;
211
-
cwd = None;
212
-
env;
213
-
continue_conversation = false;
214
-
resume = None;
215
-
max_turns = None;
216
-
permission_prompt_tool_name = None;
217
-
settings = None;
218
-
add_dirs = [];
219
-
extra_args = [];
220
-
debug_stderr = None;
221
-
hooks = None;
222
-
max_budget_usd = None;
223
-
fallback_model = None;
224
-
setting_sources = None;
225
-
max_buffer_size = None;
226
-
user = None;
227
-
output_format = None;
228
-
unknown;
229
-
}
230
-
in
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)
246
-
247
130
let log_options t =
248
-
Log.debug (fun m -> m "Claude options: %a" (Jsont.pp_value jsont ()) t)
131
+
Log.debug (fun m ->
132
+
m "Options: model=%s fallback=%s max_thinking_tokens=%d max_budget=%s"
133
+
(match t.model with
134
+
| None -> "default"
135
+
| Some m -> Proto.Model.to_string m)
136
+
(match t.fallback_model with
137
+
| None -> "none"
138
+
| Some m -> Proto.Model.to_string m)
139
+
t.max_thinking_tokens
140
+
(match t.max_budget_usd with
141
+
| None -> "unlimited"
142
+
| Some b -> Printf.sprintf "$%.2f" b))
143
+
144
+
module Advanced = struct
145
+
let to_wire (t : t) : Proto.Options.t =
146
+
let base = Proto.Options.empty in
147
+
let base = Proto.Options.with_allowed_tools t.allowed_tools base in
148
+
let base = Proto.Options.with_disallowed_tools t.disallowed_tools base in
149
+
let base = Proto.Options.with_max_thinking_tokens t.max_thinking_tokens base in
150
+
let base =
151
+
match t.system_prompt with
152
+
| None -> base
153
+
| Some p -> Proto.Options.with_system_prompt p base
154
+
in
155
+
let base =
156
+
match t.append_system_prompt with
157
+
| None -> base
158
+
| Some p -> Proto.Options.with_append_system_prompt p base
159
+
in
160
+
let base =
161
+
match t.permission_mode with
162
+
| None -> base
163
+
| Some m ->
164
+
Proto.Options.with_permission_mode (Permissions.Mode.to_proto m) base
165
+
in
166
+
let base =
167
+
match t.model with
168
+
| None -> base
169
+
| Some m -> Proto.Options.with_model m base
170
+
in
171
+
let base =
172
+
Proto.Options.with_continue_conversation t.continue_conversation base
173
+
in
174
+
let base =
175
+
match t.resume with
176
+
| None -> base
177
+
| Some r -> Proto.Options.with_resume r base
178
+
in
179
+
let base =
180
+
match t.max_turns with
181
+
| None -> base
182
+
| Some turns -> Proto.Options.with_max_turns turns base
183
+
in
184
+
let base =
185
+
match t.permission_prompt_tool_name with
186
+
| None -> base
187
+
| Some tool -> Proto.Options.with_permission_prompt_tool_name tool base
188
+
in
189
+
let base =
190
+
match t.settings with
191
+
| None -> base
192
+
| Some s -> Proto.Options.with_settings s base
193
+
in
194
+
let base = Proto.Options.with_add_dirs t.add_dirs base in
195
+
let base =
196
+
match t.max_budget_usd with
197
+
| None -> base
198
+
| Some b -> Proto.Options.with_max_budget_usd b base
199
+
in
200
+
let base =
201
+
match t.fallback_model with
202
+
| None -> base
203
+
| Some m -> Proto.Options.with_fallback_model m base
204
+
in
205
+
let base =
206
+
match t.setting_sources with
207
+
| None -> base
208
+
| Some sources -> Proto.Options.with_setting_sources sources base
209
+
in
210
+
let base =
211
+
match t.max_buffer_size with
212
+
| None -> base
213
+
| Some size -> Proto.Options.with_max_buffer_size size base
214
+
in
215
+
let base =
216
+
match t.user with
217
+
| None -> base
218
+
| Some u -> Proto.Options.with_user u base
219
+
in
220
+
let base =
221
+
match t.output_format with
222
+
| None -> base
223
+
| Some format -> Proto.Options.with_output_format format base
224
+
in
225
+
base
226
+
end
+100
-216
lib/options.mli
+100
-216
lib/options.mli
···
23
23
{[
24
24
let options =
25
25
Options.default
26
-
|> Options.with_model "claude-sonnet-4-5"
26
+
|> Options.with_model `Sonnet_4_5
27
27
|> Options.with_max_budget_usd 1.0
28
28
|> Options.with_permission_mode Permissions.Mode.Accept_edits
29
29
]}
···
37
37
Options.default |> Options.with_no_settings (* Ignore user config *)
38
38
|> Options.with_max_budget_usd 0.50 (* 50 cent limit *)
39
39
|> Options.with_permission_mode Permissions.Mode.Bypass_permissions
40
-
|> Options.with_model "claude-haiku-4"
40
+
|> Options.with_model `Haiku_4
41
41
]}
42
42
43
43
{3 Production: Cost Control with Fallback}
···
45
45
{[
46
46
let prod_config =
47
47
Options.default
48
-
|> Options.with_model "claude-sonnet-4-5"
49
-
|> Options.with_fallback_model "claude-haiku-4"
48
+
|> Options.with_model `Sonnet_4_5
49
+
|> Options.with_fallback_model `Haiku_4
50
50
|> Options.with_max_budget_usd 10.0 (* $10 daily limit *)
51
51
|> Options.with_max_buffer_size 5_000_000
52
52
]}
···
56
56
{[
57
57
let dev_config =
58
58
Options.default
59
-
|> Options.with_setting_sources [ User; Project ]
60
59
|> Options.with_max_budget_usd 1.0
61
60
|> Options.with_permission_mode Permissions.Mode.Default
62
61
]}
63
62
64
-
{3 Structured Output: Type-Safe Responses}
65
-
66
-
{[
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
-
80
-
let format = Structured_output.of_json_schema schema
81
-
82
-
let analysis_config =
83
-
Options.default
84
-
|> Options.with_output_format format
85
-
|> Options.with_allowed_tools [ "Read"; "Glob"; "Grep" ]
86
-
]}
87
-
88
63
{2 Advanced Options}
89
64
90
65
{3 Budget Control}
···
94
69
95
70
{3 Settings Isolation}
96
71
97
-
Use {!with_setting_sources} or {!with_no_settings} to control which
98
-
configuration files are loaded:
99
-
- [User] - ~/.claude/config
100
-
- [Project] - .claude/ in project root
101
-
- [Local] - Current directory settings
102
-
- [Some []] (via {!with_no_settings}) - No settings, fully isolated
103
-
72
+
Use {!with_no_settings} to control which configuration files are loaded.
104
73
This is critical for reproducible builds in CI/CD environments.
105
74
106
75
{3 Model Fallback}
···
112
81
(** The log source for options operations *)
113
82
114
83
(** {1 Types} *)
115
-
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 *)
124
84
125
85
type t
126
86
(** The type of configuration options. *)
···
132
92
- Default allow permission callback
133
93
- No custom prompts or model override *)
134
94
135
-
val create :
136
-
?allowed_tools:string list ->
137
-
?disallowed_tools:string list ->
138
-
?max_thinking_tokens:int ->
139
-
?system_prompt:string ->
140
-
?append_system_prompt:string ->
141
-
?permission_mode:Permissions.Mode.t ->
142
-
?permission_callback:Permissions.callback ->
143
-
?model:Model.t ->
144
-
?cwd:Eio.Fs.dir_ty Eio.Path.t ->
145
-
?env:(string * string) list ->
146
-
?continue_conversation:bool ->
147
-
?resume:string ->
148
-
?max_turns:int ->
149
-
?permission_prompt_tool_name:string ->
150
-
?settings:string ->
151
-
?add_dirs:string list ->
152
-
?extra_args:(string * string option) list ->
153
-
?debug_stderr:Eio.Flow.sink_ty Eio.Flow.sink ->
154
-
?hooks:Hooks.config ->
155
-
?max_budget_usd:float ->
156
-
?fallback_model:Model.t ->
157
-
?setting_sources:setting_source list ->
158
-
?max_buffer_size:int ->
159
-
?user:string ->
160
-
?output_format:Structured_output.t ->
161
-
?unknown:Jsont.json ->
162
-
unit ->
163
-
t
164
-
(** [create ?allowed_tools ?disallowed_tools ?max_thinking_tokens ?system_prompt
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.
170
-
@param allowed_tools List of explicitly allowed tool names
171
-
@param disallowed_tools List of explicitly disallowed tool names
172
-
@param max_thinking_tokens
173
-
Maximum tokens for thinking blocks (default: 8000)
174
-
@param system_prompt Replace the default system prompt
175
-
@param append_system_prompt Append to the default system prompt
176
-
@param permission_mode Permission mode to use
177
-
@param permission_callback Custom permission callback
178
-
@param model Override the default model
179
-
@param cwd Working directory for file operations
180
-
@param env Environment variables to set
181
-
@param continue_conversation Continue an existing conversation
182
-
@param resume Resume from a specific session ID
183
-
@param max_turns Maximum number of conversation turns
184
-
@param permission_prompt_tool_name Tool name for permission prompts
185
-
@param settings Path to settings file
186
-
@param add_dirs Additional directories to allow access to
187
-
@param extra_args Additional CLI flags to pass through
188
-
@param debug_stderr Sink for debug output when debug-to-stderr is set
189
-
@param hooks Hooks configuration for event interception
190
-
@param max_budget_usd Hard spending limit in USD (terminates on exceed)
191
-
@param fallback_model Automatic fallback on primary model unavailability
192
-
@param setting_sources Control which settings load (user/project/local)
193
-
@param max_buffer_size Control for stdout buffer size in bytes
194
-
@param user Unix user for subprocess execution
195
-
@param output_format Optional structured output format specification *)
196
-
197
-
(** {1 Accessors} *)
198
-
199
-
val allowed_tools : t -> string list
200
-
(** [allowed_tools t] returns the list of allowed tools. *)
201
-
202
-
val disallowed_tools : t -> string list
203
-
(** [disallowed_tools t] returns the list of disallowed tools. *)
204
-
205
-
val max_thinking_tokens : t -> int
206
-
(** [max_thinking_tokens t] returns the maximum thinking tokens. *)
207
-
208
-
val system_prompt : t -> string option
209
-
(** [system_prompt t] returns the optional system prompt override. *)
210
-
211
-
val append_system_prompt : t -> string option
212
-
(** [append_system_prompt t] returns the optional system prompt append. *)
213
-
214
-
val permission_mode : t -> Permissions.Mode.t option
215
-
(** [permission_mode t] returns the optional permission mode. *)
216
-
217
-
val permission_callback : t -> Permissions.callback option
218
-
(** [permission_callback t] returns the optional permission callback. *)
219
-
220
-
val model : t -> Model.t option
221
-
(** [model t] returns the optional model override. *)
222
-
223
-
val cwd : t -> Eio.Fs.dir_ty Eio.Path.t option
224
-
(** [cwd t] returns the optional working directory. *)
225
-
226
-
val env : t -> (string * string) list
227
-
(** [env t] returns the environment variables. *)
228
-
229
-
val continue_conversation : t -> bool
230
-
(** [continue_conversation t] returns whether to continue an existing
231
-
conversation. *)
232
-
233
-
val resume : t -> string option
234
-
(** [resume t] returns the optional session ID to resume. *)
235
-
236
-
val max_turns : t -> int option
237
-
(** [max_turns t] returns the optional maximum number of turns. *)
238
-
239
-
val permission_prompt_tool_name : t -> string option
240
-
(** [permission_prompt_tool_name t] returns the optional tool name for
241
-
permission prompts. *)
242
-
243
-
val settings : t -> string option
244
-
(** [settings t] returns the optional path to settings file. *)
245
-
246
-
val add_dirs : t -> string list
247
-
(** [add_dirs t] returns the list of additional allowed directories. *)
248
-
249
-
val extra_args : t -> (string * string option) list
250
-
(** [extra_args t] returns the additional CLI flags. *)
251
-
252
-
val debug_stderr : t -> Eio.Flow.sink_ty Eio.Flow.sink option
253
-
(** [debug_stderr t] returns the optional debug output sink. *)
254
-
255
-
val hooks : t -> Hooks.config option
256
-
(** [hooks t] returns the optional hooks configuration. *)
257
-
258
-
val max_budget_usd : t -> float option
259
-
(** [max_budget_usd t] returns the optional spending limit in USD. *)
260
-
261
-
val fallback_model : t -> Model.t option
262
-
(** [fallback_model t] returns the optional fallback model. *)
263
-
264
-
val setting_sources : t -> setting_source list option
265
-
(** [setting_sources t] returns the optional list of setting sources to load. *)
266
-
267
-
val max_buffer_size : t -> int option
268
-
(** [max_buffer_size t] returns the optional stdout buffer size in bytes. *)
269
-
270
-
val user : t -> string option
271
-
(** [user t] returns the optional Unix user for subprocess execution. *)
272
-
273
-
val output_format : t -> Structured_output.t option
274
-
(** [output_format t] returns the optional structured output format. *)
275
-
276
-
val unknown : t -> Jsont.json
277
-
(** [unknown t] returns any unknown JSON fields that were preserved during
278
-
decoding. *)
279
-
280
-
(** {1 Builders} *)
95
+
(** {1 Builder Pattern} *)
281
96
282
97
val with_allowed_tools : string list -> t -> t
283
98
(** [with_allowed_tools tools t] sets the allowed tools. *)
···
300
115
val with_permission_callback : Permissions.callback -> t -> t
301
116
(** [with_permission_callback callback t] sets the permission callback. *)
302
117
303
-
val with_model : Model.t -> t -> t
118
+
val with_model : Proto.Model.t -> t -> t
304
119
(** [with_model model t] sets the model override using a typed Model.t. *)
305
120
306
-
val with_model_string : string -> t -> t
307
-
(** [with_model_string model t] sets the model override from a string. The
308
-
string is parsed using {!Model.of_string}. *)
309
-
310
-
val with_cwd : Eio.Fs.dir_ty Eio.Path.t -> t -> t
121
+
val with_cwd : [> Eio.Fs.dir_ty ] Eio.Path.t -> t -> t
311
122
(** [with_cwd cwd t] sets the working directory. *)
312
123
313
124
val with_env : (string * string) list -> t -> t
···
333
144
val with_add_dirs : string list -> t -> t
334
145
(** [with_add_dirs dirs t] sets the additional allowed directories. *)
335
146
336
-
val with_extra_args : (string * string option) list -> t -> t
337
-
(** [with_extra_args args t] sets the additional CLI flags. *)
338
-
339
-
val with_debug_stderr : Eio.Flow.sink_ty Eio.Flow.sink -> t -> t
147
+
val with_debug_stderr : [> Eio.Flow.sink_ty ] Eio.Flow.sink -> t -> t
340
148
(** [with_debug_stderr sink t] sets the debug output sink. *)
341
149
342
-
val with_hooks : Hooks.config -> t -> t
150
+
val with_hooks : Hooks.t -> t -> t
343
151
(** [with_hooks hooks t] sets the hooks configuration. *)
344
152
345
153
val with_max_budget_usd : float -> t -> t
346
154
(** [with_max_budget_usd budget t] sets the maximum spending limit in USD. The
347
155
session will terminate if this limit is exceeded. *)
348
156
349
-
val with_fallback_model : Model.t -> t -> t
157
+
val with_fallback_model : Proto.Model.t -> t -> t
350
158
(** [with_fallback_model model t] sets the fallback model using a typed Model.t.
351
159
*)
352
160
353
-
val with_fallback_model_string : string -> t -> t
354
-
(** [with_fallback_model_string model t] sets the fallback model from a string.
355
-
The string is parsed using {!Model.of_string}. *)
356
-
357
-
val with_setting_sources : setting_source list -> t -> t
358
-
(** [with_setting_sources sources t] sets which configuration sources to load.
359
-
Use empty list for isolated environments (e.g., CI/CD). *)
360
-
361
161
val with_no_settings : t -> t
362
162
(** [with_no_settings t] disables all settings loading (user, project, local).
363
163
Useful for CI/CD environments where you want isolated, reproducible
···
370
170
val with_user : string -> t -> t
371
171
(** [with_user user t] sets the Unix user for subprocess execution. *)
372
172
373
-
val with_output_format : Structured_output.t -> t -> t
173
+
val with_output_format : Proto.Structured_output.t -> t -> t
374
174
(** [with_output_format format t] sets the structured output format. *)
375
175
376
-
(** {1 Serialization} *)
176
+
val with_extra_args : (string * string option) list -> t -> t
177
+
(** [with_extra_args args t] sets the additional CLI flags. *)
178
+
179
+
(** {1 Accessors} *)
180
+
181
+
val allowed_tools : t -> string list
182
+
(** [allowed_tools t] returns the list of allowed tools. *)
377
183
378
-
val jsont : t Jsont.t
379
-
(** [jsont] is the Jsont codec for Options.t Use [Jsont.pp_value jsont ()] for
380
-
pretty-printing. *)
184
+
val disallowed_tools : t -> string list
185
+
(** [disallowed_tools t] returns the list of disallowed tools. *)
186
+
187
+
val max_thinking_tokens : t -> int
188
+
(** [max_thinking_tokens t] returns the maximum thinking tokens. *)
189
+
190
+
val system_prompt : t -> string option
191
+
(** [system_prompt t] returns the optional system prompt override. *)
192
+
193
+
val append_system_prompt : t -> string option
194
+
(** [append_system_prompt t] returns the optional system prompt append. *)
195
+
196
+
val permission_mode : t -> Permissions.Mode.t option
197
+
(** [permission_mode t] returns the optional permission mode. *)
198
+
199
+
val permission_callback : t -> Permissions.callback option
200
+
(** [permission_callback t] returns the optional permission callback. *)
201
+
202
+
val model : t -> Proto.Model.t option
203
+
(** [model t] returns the optional model override. *)
204
+
205
+
val cwd : t -> Eio.Fs.dir_ty Eio.Path.t option
206
+
(** [cwd t] returns the optional working directory. *)
207
+
208
+
val env : t -> (string * string) list
209
+
(** [env t] returns the environment variables. *)
210
+
211
+
val continue_conversation : t -> bool
212
+
(** [continue_conversation t] returns whether to continue an existing
213
+
conversation. *)
214
+
215
+
val resume : t -> string option
216
+
(** [resume t] returns the optional session ID to resume. *)
217
+
218
+
val max_turns : t -> int option
219
+
(** [max_turns t] returns the optional maximum number of turns. *)
220
+
221
+
val permission_prompt_tool_name : t -> string option
222
+
(** [permission_prompt_tool_name t] returns the optional tool name for
223
+
permission prompts. *)
224
+
225
+
val settings : t -> string option
226
+
(** [settings t] returns the optional path to settings file. *)
227
+
228
+
val add_dirs : t -> string list
229
+
(** [add_dirs t] returns the list of additional allowed directories. *)
230
+
231
+
val debug_stderr : t -> Eio.Flow.sink_ty Eio.Flow.sink option
232
+
(** [debug_stderr t] returns the optional debug output sink. *)
233
+
234
+
val hooks : t -> Hooks.t option
235
+
(** [hooks t] returns the optional hooks configuration. *)
236
+
237
+
val max_budget_usd : t -> float option
238
+
(** [max_budget_usd t] returns the optional spending limit in USD. *)
239
+
240
+
val fallback_model : t -> Proto.Model.t option
241
+
(** [fallback_model t] returns the optional fallback model. *)
242
+
243
+
val setting_sources : t -> Proto.Options.setting_source list option
244
+
(** [setting_sources t] returns the optional list of setting sources to load. *)
245
+
246
+
val max_buffer_size : t -> int option
247
+
(** [max_buffer_size t] returns the optional stdout buffer size in bytes. *)
248
+
249
+
val user : t -> string option
250
+
(** [user t] returns the optional Unix user for subprocess execution. *)
251
+
252
+
val output_format : t -> Proto.Structured_output.t option
253
+
(** [output_format t] returns the optional structured output format. *)
254
+
255
+
val extra_args : t -> (string * string option) list
256
+
(** [extra_args t] returns the additional CLI flags. *)
381
257
382
258
(** {1 Logging} *)
383
259
384
260
val log_options : t -> unit
385
261
(** [log_options t] logs the current options configuration. *)
262
+
263
+
(** {1 Advanced: Wire Format Conversion} *)
264
+
265
+
module Advanced : sig
266
+
val to_wire : t -> Proto.Options.t
267
+
(** [to_wire t] converts to wire format (excludes Eio types and callbacks).
268
+
This is used internally by the client to send options to the Claude CLI. *)
269
+
end
+68
-234
lib/permissions.ml
+68
-234
lib/permissions.ml
···
21
21
raise
22
22
(Invalid_argument (Printf.sprintf "Mode.of_string: unknown mode %s" s))
23
23
24
-
let jsont : t Jsont.t =
25
-
Jsont.enum
26
-
[
27
-
("default", Default);
28
-
("acceptEdits", Accept_edits);
29
-
("plan", Plan);
30
-
("bypassPermissions", Bypass_permissions);
31
-
]
32
-
end
33
-
34
-
(** Permission behaviors *)
35
-
module Behavior = struct
36
-
type t = Allow | Deny | Ask
37
-
38
-
let to_string = function Allow -> "allow" | Deny -> "deny" | Ask -> "ask"
39
-
40
-
let of_string = function
41
-
| "allow" -> Allow
42
-
| "deny" -> Deny
43
-
| "ask" -> Ask
44
-
| s ->
45
-
raise
46
-
(Invalid_argument
47
-
(Printf.sprintf "Behavior.of_string: unknown behavior %s" s))
24
+
let of_proto : Proto.Permissions.Mode.t -> t = function
25
+
| Proto.Permissions.Mode.Default -> Default
26
+
| Proto.Permissions.Mode.Accept_edits -> Accept_edits
27
+
| Proto.Permissions.Mode.Plan -> Plan
28
+
| Proto.Permissions.Mode.Bypass_permissions -> Bypass_permissions
48
29
49
-
let jsont : t Jsont.t =
50
-
Jsont.enum [ ("allow", Allow); ("deny", Deny); ("ask", Ask) ]
30
+
let to_proto : t -> Proto.Permissions.Mode.t = function
31
+
| Default -> Proto.Permissions.Mode.Default
32
+
| Accept_edits -> Proto.Permissions.Mode.Accept_edits
33
+
| Plan -> Proto.Permissions.Mode.Plan
34
+
| Bypass_permissions -> Proto.Permissions.Mode.Bypass_permissions
51
35
end
52
36
53
37
(** Permission rules *)
54
38
module Rule = struct
55
-
type t = {
56
-
tool_name : string;
57
-
rule_content : string option;
58
-
unknown : Unknown.t;
59
-
}
60
-
61
-
let create ~tool_name ?rule_content ?(unknown = Unknown.empty) () =
62
-
{ tool_name; rule_content; unknown }
39
+
type t = { tool_name : string; rule_content : string option }
63
40
41
+
let create ~tool_name ?rule_content () = { tool_name; rule_content }
64
42
let tool_name t = t.tool_name
65
43
let rule_content t = t.rule_content
66
-
let unknown t = t.unknown
67
-
68
-
let jsont : t Jsont.t =
69
-
let make tool_name rule_content unknown =
70
-
{ tool_name; rule_content; unknown }
71
-
in
72
-
Jsont.Object.map ~kind:"Rule" make
73
-
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:tool_name
74
-
|> Jsont.Object.opt_mem "rule_content" Jsont.string ~enc:rule_content
75
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
76
-
|> Jsont.Object.finish
77
-
end
78
-
79
-
(** Permission updates *)
80
-
module Update = struct
81
-
type destination =
82
-
| User_settings
83
-
| Project_settings
84
-
| Local_settings
85
-
| Session
86
-
87
-
let _destination_of_string = function
88
-
| "userSettings" -> User_settings
89
-
| "projectSettings" -> Project_settings
90
-
| "localSettings" -> Local_settings
91
-
| "session" -> Session
92
-
| s ->
93
-
raise
94
-
(Invalid_argument
95
-
(Printf.sprintf "destination_of_string: unknown %s" s))
96
44
97
-
let destination_jsont : destination Jsont.t =
98
-
Jsont.enum
99
-
[
100
-
("userSettings", User_settings);
101
-
("projectSettings", Project_settings);
102
-
("localSettings", Local_settings);
103
-
("session", Session);
104
-
]
105
-
106
-
type update_type =
107
-
| Add_rules
108
-
| Replace_rules
109
-
| Remove_rules
110
-
| Set_mode
111
-
| Add_directories
112
-
| Remove_directories
113
-
114
-
let _update_type_of_string = function
115
-
| "addRules" -> Add_rules
116
-
| "replaceRules" -> Replace_rules
117
-
| "removeRules" -> Remove_rules
118
-
| "setMode" -> Set_mode
119
-
| "addDirectories" -> Add_directories
120
-
| "removeDirectories" -> Remove_directories
121
-
| s ->
122
-
raise
123
-
(Invalid_argument
124
-
(Printf.sprintf "update_type_of_string: unknown %s" s))
125
-
126
-
let update_type_jsont : update_type Jsont.t =
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
-
]
136
-
137
-
type t = {
138
-
update_type : update_type;
139
-
rules : Rule.t list option;
140
-
behavior : Behavior.t option;
141
-
mode : Mode.t option;
142
-
directories : string list option;
143
-
destination : destination option;
144
-
unknown : Unknown.t;
145
-
}
146
-
147
-
let create ~update_type ?rules ?behavior ?mode ?directories ?destination
148
-
?(unknown = Unknown.empty) () =
149
-
{ update_type; rules; behavior; mode; directories; destination; unknown }
150
-
151
-
let update_type t = t.update_type
152
-
let rules t = t.rules
153
-
let behavior t = t.behavior
154
-
let mode t = t.mode
155
-
let directories t = t.directories
156
-
let destination t = t.destination
157
-
let unknown t = t.unknown
158
-
159
-
let jsont : t Jsont.t =
160
-
let make update_type rules behavior mode directories destination unknown =
161
-
{ update_type; rules; behavior; mode; directories; destination; unknown }
162
-
in
163
-
Jsont.Object.map ~kind:"Update" make
164
-
|> Jsont.Object.mem "type" update_type_jsont ~enc:update_type
165
-
|> Jsont.Object.opt_mem "rules" (Jsont.list Rule.jsont) ~enc:rules
166
-
|> Jsont.Object.opt_mem "behavior" Behavior.jsont ~enc:behavior
167
-
|> Jsont.Object.opt_mem "mode" Mode.jsont ~enc:mode
168
-
|> Jsont.Object.opt_mem "directories" (Jsont.list Jsont.string)
169
-
~enc:directories
170
-
|> Jsont.Object.opt_mem "destination" destination_jsont ~enc:destination
171
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
172
-
|> Jsont.Object.finish
173
-
end
45
+
let of_proto (proto : Proto.Permissions.Rule.t) : t =
46
+
{
47
+
tool_name = Proto.Permissions.Rule.tool_name proto;
48
+
rule_content = Proto.Permissions.Rule.rule_content proto;
49
+
}
174
50
175
-
(** Permission context for callbacks *)
176
-
module Context = struct
177
-
type t = { suggestions : Update.t list; unknown : Unknown.t }
178
-
179
-
let create ?(suggestions = []) ?(unknown = Unknown.empty) () =
180
-
{ suggestions; unknown }
181
-
182
-
let suggestions t = t.suggestions
183
-
let unknown t = t.unknown
184
-
185
-
let jsont : t Jsont.t =
186
-
let make suggestions unknown = { suggestions; unknown } in
187
-
Jsont.Object.map ~kind:"Context" make
188
-
|> Jsont.Object.mem "suggestions" (Jsont.list Update.jsont) ~enc:suggestions
189
-
~dec_absent:[]
190
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
191
-
|> Jsont.Object.finish
51
+
let to_proto (t : t) : Proto.Permissions.Rule.t =
52
+
Proto.Permissions.Rule.create ~tool_name:t.tool_name ?rule_content:t.rule_content
53
+
()
192
54
end
193
55
194
-
(** Permission results *)
195
-
module Result = struct
56
+
(** Permission decisions *)
57
+
module Decision = struct
196
58
type t =
197
-
| Allow of {
198
-
updated_input : Jsont.json option;
199
-
updated_permissions : Update.t list option;
200
-
unknown : Unknown.t;
201
-
}
202
-
| Deny of { message : string; interrupt : bool; unknown : Unknown.t }
59
+
| Allow of { updated_input : Tool_input.t option }
60
+
| Deny of { message : string; interrupt : bool }
203
61
204
-
let allow ?updated_input ?updated_permissions ?(unknown = Unknown.empty) () =
205
-
Allow { updated_input; updated_permissions; unknown }
62
+
let allow ?updated_input () = Allow { updated_input }
63
+
let deny ~message ~interrupt = Deny { message; interrupt }
206
64
207
-
let deny ~message ~interrupt ?(unknown = Unknown.empty) () =
208
-
Deny { message; interrupt; unknown }
65
+
let is_allow = function Allow _ -> true | Deny _ -> false
66
+
let is_deny = function Allow _ -> false | Deny _ -> true
209
67
210
-
let jsont : t Jsont.t =
211
-
let allow_record =
212
-
let make updated_input updated_permissions unknown =
213
-
Allow { updated_input; updated_permissions; unknown }
214
-
in
215
-
Jsont.Object.map ~kind:"AllowRecord" make
216
-
|> Jsont.Object.opt_mem "updated_input" Jsont.json ~enc:(function
217
-
| Allow { updated_input; _ } -> updated_input
218
-
| _ -> None)
219
-
|> Jsont.Object.opt_mem "updated_permissions" (Jsont.list Update.jsont)
220
-
~enc:(function
221
-
| Allow { updated_permissions; _ } -> updated_permissions
222
-
| _ -> None)
223
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(function
224
-
| Allow { unknown; _ } -> unknown
225
-
| _ -> Unknown.empty)
226
-
|> Jsont.Object.finish
227
-
in
228
-
let deny_record =
229
-
let make message interrupt unknown =
230
-
Deny { message; interrupt; unknown }
231
-
in
232
-
Jsont.Object.map ~kind:"DenyRecord" make
233
-
|> Jsont.Object.mem "message" Jsont.string ~enc:(function
234
-
| Deny { message; _ } -> message
235
-
| _ -> "")
236
-
|> Jsont.Object.mem "interrupt" Jsont.bool ~enc:(function
237
-
| Deny { interrupt; _ } -> interrupt
238
-
| _ -> false)
239
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(function
240
-
| Deny { unknown; _ } -> unknown
241
-
| _ -> Unknown.empty)
242
-
|> Jsont.Object.finish
243
-
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
68
+
let updated_input = function
69
+
| Allow { updated_input } -> updated_input
70
+
| Deny _ -> None
250
71
251
-
let enc_case = function
252
-
| Allow _ as v -> Jsont.Object.Case.value case_allow v
253
-
| Deny _ as v -> Jsont.Object.Case.value case_deny v
254
-
in
72
+
let deny_message = function
73
+
| Allow _ -> None
74
+
| Deny { message; _ } -> Some message
255
75
256
-
let cases = Jsont.Object.Case.[ make case_allow; make case_deny ] in
76
+
let deny_interrupt = function Allow _ -> false | Deny { interrupt; _ } -> interrupt
257
77
258
-
Jsont.Object.map ~kind:"Result" Fun.id
259
-
|> Jsont.Object.case_mem "behavior" Jsont.string ~enc:Fun.id ~enc_case cases
260
-
~tag_to_string:Fun.id ~tag_compare:String.compare
261
-
|> Jsont.Object.finish
78
+
let to_proto_result (t : t) : Proto.Permissions.Result.t =
79
+
match t with
80
+
| Allow { updated_input } ->
81
+
let updated_input_json =
82
+
Option.map Tool_input.to_json updated_input
83
+
in
84
+
Proto.Permissions.Result.allow ?updated_input:updated_input_json ()
85
+
| Deny { message; interrupt } ->
86
+
Proto.Permissions.Result.deny ~message ~interrupt ()
262
87
end
263
88
264
-
type callback =
265
-
tool_name:string -> input:Jsont.json -> context:Context.t -> Result.t
89
+
(** Permission context *)
90
+
type context = {
91
+
tool_name : string;
92
+
input : Tool_input.t;
93
+
suggested_rules : Rule.t list;
94
+
}
95
+
96
+
let extract_rules_from_proto_updates updates =
97
+
List.concat_map
98
+
(fun update ->
99
+
match Proto.Permissions.Update.rules update with
100
+
| Some rules -> List.map Rule.of_proto rules
101
+
| None -> [])
102
+
updates
103
+
266
104
(** Permission callback type *)
105
+
type callback = context -> Decision.t
267
106
268
107
(** Default callbacks *)
269
-
let default_allow_callback ~tool_name:_ ~input:_ ~context:_ = Result.allow ()
108
+
let default_allow _ctx = Decision.allow ()
270
109
271
-
let discovery_callback log ~tool_name:_ ~input:_ ~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);
278
-
Result.allow ()
110
+
let discovery log ctx =
111
+
List.iter (fun rule -> log := rule :: !log) ctx.suggested_rules;
112
+
Decision.allow ()
279
113
280
114
(** Logging *)
281
-
let log_permission_check ~tool_name ~result =
282
-
match result with
283
-
| Result.Allow _ ->
115
+
let log_permission_check ~tool_name ~decision =
116
+
match decision with
117
+
| Decision.Allow _ ->
284
118
Log.info (fun m -> m "Permission granted for tool: %s" tool_name)
285
-
| Result.Deny { message; _ } ->
119
+
| Decision.Deny { message; _ } ->
286
120
Log.warn (fun m ->
287
121
m "Permission denied for tool %s: %s" tool_name message)
+63
-176
lib/permissions.mli
+63
-176
lib/permissions.mli
···
1
-
(** Permission system for Claude tool invocations.
1
+
(** Permission control for tool usage.
2
2
3
3
This module provides a permission system for controlling which tools Claude
4
4
can invoke and how they can be used. It includes support for permission
5
-
modes, rules, updates, and callbacks. *)
5
+
modes, rules, decisions, and callbacks. *)
6
6
7
7
val src : Logs.Src.t
8
-
(** The log source for permission operations *)
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. *)
16
15
type t =
17
16
| Default (** Standard permission mode with normal checks *)
18
17
| Accept_edits (** Automatically accept file edits *)
19
18
| Plan (** Planning mode with restricted execution *)
20
19
| 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. *)
···
26
26
(** [of_string s] parses a mode from its string representation.
27
27
@raise Invalid_argument if the string is not a valid mode. *)
28
28
29
-
val jsont : t Jsont.t
30
-
(** [jsont] is the Jsont codec for permission modes. Use
31
-
[Jsont.pp_value jsont ()] for pretty-printing. *)
32
-
end
33
-
34
-
(** {1 Permission Behaviors} *)
35
-
36
-
module Behavior : sig
37
-
(** Behaviors determine how permission requests are handled. *)
38
-
39
-
(** The type of permission behaviors. *)
40
-
type t =
41
-
| Allow (** Allow the operation *)
42
-
| Deny (** Deny the operation *)
43
-
| Ask (** Ask the user for permission *)
44
-
45
-
val to_string : t -> string
46
-
(** [to_string t] converts a behavior to its string representation. *)
47
-
48
-
val of_string : string -> t
49
-
(** [of_string s] parses a behavior from its string representation.
50
-
@raise Invalid_argument if the string is not a valid behavior. *)
29
+
val of_proto : Proto.Permissions.Mode.t -> t
30
+
(** [of_proto proto] converts from the protocol representation. *)
51
31
52
-
val jsont : t Jsont.t
53
-
(** [jsont] is the Jsont codec for permission behaviors. Use
54
-
[Jsont.pp_value jsont ()] for pretty-printing. *)
32
+
val to_proto : t -> Proto.Permissions.Mode.t
33
+
(** [to_proto t] converts to the protocol representation. *)
55
34
end
56
35
57
36
(** {1 Permission Rules} *)
···
59
38
module Rule : sig
60
39
(** Rules define specific permissions for tools. *)
61
40
62
-
type t = {
63
-
tool_name : string; (** Name of the tool *)
64
-
rule_content : string option; (** Optional rule specification *)
65
-
unknown : Unknown.t; (** Unknown fields *)
66
-
}
41
+
type t
67
42
(** The type of permission rules. *)
68
43
69
-
val create :
70
-
tool_name:string -> ?rule_content:string -> ?unknown:Unknown.t -> unit -> t
71
-
(** [create ~tool_name ?rule_content ?unknown ()] creates a new rule.
44
+
val create : tool_name:string -> ?rule_content:string -> unit -> t
45
+
(** [create ~tool_name ?rule_content ()] creates a new rule.
72
46
@param tool_name The name of the tool this rule applies to
73
-
@param rule_content Optional rule specification or pattern
74
-
@param unknown Optional unknown fields to preserve *)
47
+
@param rule_content Optional rule specification or pattern *)
75
48
76
49
val tool_name : t -> string
77
50
(** [tool_name t] returns the tool name. *)
···
79
52
val rule_content : t -> string option
80
53
(** [rule_content t] returns the optional rule content. *)
81
54
82
-
val unknown : t -> Unknown.t
83
-
(** [unknown t] returns the unknown fields. *)
55
+
val of_proto : Proto.Permissions.Rule.t -> t
56
+
(** [of_proto proto] converts from the protocol representation. *)
84
57
85
-
val jsont : t Jsont.t
86
-
(** [jsont] is the Jsont codec for permission rules. Use
87
-
[Jsont.pp_value jsont ()] for pretty-printing. *)
58
+
val to_proto : t -> Proto.Permissions.Rule.t
59
+
(** [to_proto t] converts to the protocol representation. *)
88
60
end
89
61
90
-
(** {1 Permission Updates} *)
91
-
92
-
module Update : sig
93
-
(** Updates modify permission settings. *)
62
+
(** {1 Permission Decisions} *)
94
63
95
-
(** The destination for permission updates. *)
96
-
type destination =
97
-
| User_settings (** Apply to user settings *)
98
-
| Project_settings (** Apply to project settings *)
99
-
| Local_settings (** Apply to local settings *)
100
-
| Session (** Apply to current session only *)
101
-
102
-
(** The type of permission update. *)
103
-
type update_type =
104
-
| Add_rules (** Add new rules *)
105
-
| Replace_rules (** Replace existing rules *)
106
-
| Remove_rules (** Remove rules *)
107
-
| Set_mode (** Set permission mode *)
108
-
| Add_directories (** Add allowed directories *)
109
-
| Remove_directories (** Remove allowed directories *)
64
+
module Decision : sig
65
+
(** Decisions represent the outcome of a permission check. *)
110
66
111
67
type t
112
-
(** The type of permission updates. *)
68
+
(** The type of permission decisions. *)
113
69
114
-
val create :
115
-
update_type:update_type ->
116
-
?rules:Rule.t list ->
117
-
?behavior:Behavior.t ->
118
-
?mode:Mode.t ->
119
-
?directories:string list ->
120
-
?destination:destination ->
121
-
?unknown:Unknown.t ->
122
-
unit ->
123
-
t
124
-
(** [create ~update_type ?rules ?behavior ?mode ?directories ?destination
125
-
?unknown ()] creates a new permission update.
126
-
@param update_type The type of update to perform
127
-
@param rules Optional list of rules to add/remove/replace
128
-
@param behavior Optional behavior to set
129
-
@param mode Optional permission mode to set
130
-
@param directories Optional directories to add/remove
131
-
@param destination Optional destination for the update
132
-
@param unknown Optional unknown fields to preserve *)
70
+
val allow : ?updated_input:Tool_input.t -> unit -> t
71
+
(** [allow ?updated_input ()] creates an allow decision.
72
+
@param updated_input Optional modified tool input *)
133
73
134
-
val update_type : t -> update_type
135
-
(** [update_type t] returns the update type. *)
74
+
val deny : message:string -> interrupt:bool -> t
75
+
(** [deny ~message ~interrupt] creates a deny decision.
76
+
@param message The reason for denying permission
77
+
@param interrupt Whether to interrupt further execution *)
136
78
137
-
val rules : t -> Rule.t list option
138
-
(** [rules t] returns the optional list of rules. *)
79
+
val is_allow : t -> bool
80
+
(** [is_allow t] returns true if the decision allows the operation. *)
139
81
140
-
val behavior : t -> Behavior.t option
141
-
(** [behavior t] returns the optional behavior. *)
82
+
val is_deny : t -> bool
83
+
(** [is_deny t] returns true if the decision denies the operation. *)
142
84
143
-
val mode : t -> Mode.t option
144
-
(** [mode t] returns the optional mode. *)
85
+
val updated_input : t -> Tool_input.t option
86
+
(** [updated_input t] returns the optional updated tool input if the decision
87
+
is allow. *)
145
88
146
-
val directories : t -> string list option
147
-
(** [directories t] returns the optional list of directories. *)
89
+
val deny_message : t -> string option
90
+
(** [deny_message t] returns the denial message if the decision is deny. *)
148
91
149
-
val destination : t -> destination option
150
-
(** [destination t] returns the optional destination. *)
151
-
152
-
val unknown : t -> Unknown.t
153
-
(** [unknown t] returns the unknown fields. *)
92
+
val deny_interrupt : t -> bool
93
+
(** [deny_interrupt t] returns whether to interrupt if the decision is deny. *)
154
94
155
-
val jsont : t Jsont.t
156
-
(** [jsont] is the Jsont codec for permission updates. Use
157
-
[Jsont.pp_value jsont ()] for pretty-printing. *)
95
+
val to_proto_result : t -> Proto.Permissions.Result.t
96
+
(** [to_proto_result t] converts to the protocol result representation. *)
158
97
end
159
98
160
99
(** {1 Permission Context} *)
161
100
162
-
module Context : sig
163
-
(** Context provided to permission callbacks. *)
164
-
165
-
type t = {
166
-
suggestions : Update.t list; (** Suggested permission updates *)
167
-
unknown : Unknown.t; (** Unknown fields *)
168
-
}
169
-
(** The type of permission context. *)
170
-
171
-
val create : ?suggestions:Update.t list -> ?unknown:Unknown.t -> unit -> t
172
-
(** [create ?suggestions ?unknown ()] creates a new context.
173
-
@param suggestions Optional list of suggested permission updates
174
-
@param unknown Optional unknown fields to preserve *)
175
-
176
-
val suggestions : t -> Update.t list
177
-
(** [suggestions t] returns the list of suggested updates. *)
178
-
179
-
val unknown : t -> Unknown.t
180
-
(** [unknown t] returns the unknown fields. *)
181
-
182
-
val jsont : t Jsont.t
183
-
(** [jsont] is the Jsont codec for permission context. Use
184
-
[Jsont.pp_value jsont ()] for pretty-printing. *)
185
-
end
101
+
type context = {
102
+
tool_name : string; (** Name of the tool being invoked *)
103
+
input : Tool_input.t; (** Tool input parameters *)
104
+
suggested_rules : Rule.t list; (** Suggested permission rules *)
105
+
}
106
+
(** The context provided to permission callbacks. *)
186
107
187
-
(** {1 Permission Results} *)
188
-
189
-
module Result : sig
190
-
(** Results of permission checks. *)
191
-
192
-
type t =
193
-
| Allow of {
194
-
updated_input : Jsont.json option; (** Modified tool input *)
195
-
updated_permissions : Update.t list option;
196
-
(** Permission updates to apply *)
197
-
unknown : Unknown.t; (** Unknown fields *)
198
-
}
199
-
| Deny of {
200
-
message : string; (** Reason for denial *)
201
-
interrupt : bool; (** Whether to interrupt execution *)
202
-
unknown : Unknown.t; (** Unknown fields *)
203
-
} (** The type of permission results. *)
204
-
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.
213
-
@param updated_input Optional modified tool input
214
-
@param updated_permissions Optional permission updates to apply
215
-
@param unknown Optional unknown fields to preserve *)
216
-
217
-
val deny : message:string -> interrupt:bool -> ?unknown:Unknown.t -> unit -> t
218
-
(** [deny ~message ~interrupt ?unknown ()] creates a deny result.
219
-
@param message The reason for denying permission
220
-
@param interrupt Whether to interrupt further execution
221
-
@param unknown Optional unknown fields to preserve *)
222
-
223
-
val jsont : t Jsont.t
224
-
(** [jsont] is the Jsont codec for permission results. Use
225
-
[Jsont.pp_value jsont ()] for pretty-printing. *)
226
-
end
108
+
val extract_rules_from_proto_updates : Proto.Permissions.Update.t list -> Rule.t list
109
+
(** [extract_rules_from_proto_updates updates] extracts rules from protocol
110
+
permission updates. Used internally to convert protocol suggestions into
111
+
context rules. *)
227
112
228
113
(** {1 Permission Callbacks} *)
229
114
230
-
type callback =
231
-
tool_name:string -> input:Jsont.json -> context:Context.t -> Result.t
115
+
type callback = context -> Decision.t
232
116
(** The type of permission callbacks. Callbacks are invoked when Claude attempts
233
-
to use a tool, allowing custom permission logic. *)
117
+
to use a tool, allowing custom permission logic.
118
+
119
+
The callback receives a typed context with the tool name, input, and
120
+
suggested rules, and returns a decision to allow or deny the operation. *)
234
121
235
-
val default_allow_callback : callback
236
-
(** [default_allow_callback] always allows tool invocations. *)
122
+
val default_allow : callback
123
+
(** [default_allow] always allows tool invocations. *)
237
124
238
-
val discovery_callback : Rule.t list ref -> callback
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. *)
125
+
val discovery : Rule.t list ref -> callback
126
+
(** [discovery log] creates a callback that collects suggested rules into the
127
+
provided reference while allowing all operations. Useful for discovering
128
+
what permissions an operation requires. *)
242
129
243
130
(** {1 Logging} *)
244
131
245
-
val log_permission_check : tool_name:string -> result:Result.t -> unit
246
-
(** [log_permission_check ~tool_name ~result] logs a permission check result. *)
132
+
val log_permission_check : tool_name:string -> decision:Decision.t -> unit
133
+
(** [log_permission_check ~tool_name ~decision] logs a permission check result. *)
+115
lib/response.ml
+115
lib/response.ml
···
1
+
module Text = struct
2
+
type t = Content_block.Text.t
3
+
4
+
let content = Content_block.Text.text
5
+
let of_block block = block
6
+
end
7
+
8
+
module Tool_use = struct
9
+
type t = Content_block.Tool_use.t
10
+
11
+
let id = Content_block.Tool_use.id
12
+
let name = Content_block.Tool_use.name
13
+
let input = Content_block.Tool_use.input
14
+
let of_block block = block
15
+
end
16
+
17
+
module Thinking = struct
18
+
type t = Content_block.Thinking.t
19
+
20
+
let content = Content_block.Thinking.thinking
21
+
let signature = Content_block.Thinking.signature
22
+
let of_block block = block
23
+
end
24
+
25
+
module Init = struct
26
+
type t = Message.System.t
27
+
28
+
let session_id = Message.System.session_id
29
+
let model = Message.System.model
30
+
let cwd = Message.System.cwd
31
+
32
+
let of_system sys =
33
+
if Message.System.is_init sys then Some sys else None
34
+
end
35
+
36
+
module Error = struct
37
+
type t =
38
+
| System_error of Message.System.t
39
+
| Assistant_error of Message.Assistant.t * Message.Assistant.error
40
+
41
+
let message = function
42
+
| System_error sys ->
43
+
Option.value (Message.System.error_message sys) ~default:"Unknown error"
44
+
| Assistant_error (_, err) -> (
45
+
match err with
46
+
| `Authentication_failed -> "Authentication failed"
47
+
| `Billing_error -> "Billing error"
48
+
| `Rate_limit -> "Rate limit exceeded"
49
+
| `Invalid_request -> "Invalid request"
50
+
| `Server_error -> "Server error"
51
+
| `Unknown -> "Unknown error")
52
+
53
+
let is_system_error = function System_error _ -> true | _ -> false
54
+
55
+
let is_assistant_error = function Assistant_error _ -> true | _ -> false
56
+
57
+
let of_system sys =
58
+
if Message.System.is_error sys then Some (System_error sys) else None
59
+
60
+
let of_assistant msg =
61
+
match Message.Assistant.error msg with
62
+
| Some err -> Some (Assistant_error (msg, err))
63
+
| None -> None
64
+
end
65
+
66
+
module Complete = struct
67
+
type t = Message.Result.t
68
+
69
+
let duration_ms = Message.Result.duration_ms
70
+
let num_turns = Message.Result.num_turns
71
+
let session_id = Message.Result.session_id
72
+
let total_cost_usd = Message.Result.total_cost_usd
73
+
let usage = Message.Result.usage
74
+
let result_text = Message.Result.result_text
75
+
let structured_output = Message.Result.structured_output
76
+
let of_result result = result
77
+
end
78
+
79
+
type t =
80
+
| Text of Text.t
81
+
| Tool_use of Tool_use.t
82
+
| Tool_result of Content_block.Tool_result.t
83
+
| Thinking of Thinking.t
84
+
| Init of Init.t
85
+
| Error of Error.t
86
+
| Complete of Complete.t
87
+
88
+
let of_message = function
89
+
| Message.User _ ->
90
+
(* User messages are inputs, not responses *)
91
+
[]
92
+
| Message.Assistant msg -> (
93
+
(* Check for assistant error first *)
94
+
match Error.of_assistant msg with
95
+
| Some err -> [ Error err ]
96
+
| None ->
97
+
(* Convert content blocks to response events *)
98
+
Message.Assistant.content msg
99
+
|> List.map (function
100
+
| Content_block.Text text -> Text (Text.of_block text)
101
+
| Content_block.Tool_use tool -> Tool_use (Tool_use.of_block tool)
102
+
| Content_block.Tool_result result -> Tool_result result
103
+
| Content_block.Thinking thinking ->
104
+
Thinking (Thinking.of_block thinking)))
105
+
| Message.System sys -> (
106
+
(* System messages can be Init or Error *)
107
+
match Init.of_system sys with
108
+
| Some init -> [ Init init ]
109
+
| None -> (
110
+
match Error.of_system sys with
111
+
| Some err -> [ Error err ]
112
+
| None -> []))
113
+
| Message.Result result ->
114
+
(* Result messages become Complete events *)
115
+
[ Complete (Complete.of_result result) ]
+147
lib/response.mli
+147
lib/response.mli
···
1
+
(** High-level response events from Claude.
2
+
3
+
This module provides a unified interface for handling different types of
4
+
responses from Claude. It converts low-level message and content block types
5
+
into high-level response events that are easier to work with in application
6
+
code. *)
7
+
8
+
(** {1 Response Event Types} *)
9
+
10
+
module Text : sig
11
+
(** Text content from the assistant. *)
12
+
13
+
type t
14
+
(** The type of text response events (opaque). *)
15
+
16
+
val content : t -> string
17
+
(** [content t] returns the text content. *)
18
+
19
+
val of_block : Content_block.Text.t -> t
20
+
(** [of_block block] creates a text response from a content block. *)
21
+
end
22
+
23
+
module Tool_use : sig
24
+
(** Tool invocation request from the assistant. *)
25
+
26
+
type t
27
+
(** The type of tool use response events (opaque). *)
28
+
29
+
val id : t -> string
30
+
(** [id t] returns the unique identifier of the tool use. *)
31
+
32
+
val name : t -> string
33
+
(** [name t] returns the name of the tool being invoked. *)
34
+
35
+
val input : t -> Tool_input.t
36
+
(** [input t] returns the input parameters for the tool. *)
37
+
38
+
val of_block : Content_block.Tool_use.t -> t
39
+
(** [of_block block] creates a tool use response from a content block. *)
40
+
end
41
+
42
+
module Thinking : sig
43
+
(** Internal reasoning from the assistant. *)
44
+
45
+
type t
46
+
(** The type of thinking response events (opaque). *)
47
+
48
+
val content : t -> string
49
+
(** [content t] returns the thinking content. *)
50
+
51
+
val signature : t -> string
52
+
(** [signature t] returns the cryptographic signature. *)
53
+
54
+
val of_block : Content_block.Thinking.t -> t
55
+
(** [of_block block] creates a thinking response from a content block. *)
56
+
end
57
+
58
+
module Init : sig
59
+
(** Session initialization event. *)
60
+
61
+
type t
62
+
(** The type of init response events (opaque). *)
63
+
64
+
val session_id : t -> string option
65
+
(** [session_id t] returns the optional session identifier. *)
66
+
67
+
val model : t -> string option
68
+
(** [model t] returns the optional model name. *)
69
+
70
+
val cwd : t -> string option
71
+
(** [cwd t] returns the optional current working directory. *)
72
+
73
+
val of_system : Message.System.t -> t option
74
+
(** [of_system sys] returns Some if system message is init, None if error. *)
75
+
end
76
+
77
+
module Error : sig
78
+
(** Error events from system or assistant. *)
79
+
80
+
type t
81
+
(** The type of error response events (opaque). *)
82
+
83
+
val message : t -> string
84
+
(** [message t] returns the error message. *)
85
+
86
+
val is_system_error : t -> bool
87
+
(** [is_system_error t] returns true if this is a system error. *)
88
+
89
+
val is_assistant_error : t -> bool
90
+
(** [is_assistant_error t] returns true if this is an assistant error. *)
91
+
92
+
val of_system : Message.System.t -> t option
93
+
(** [of_system sys] returns Some if system message is error, None if init. *)
94
+
95
+
val of_assistant : Message.Assistant.t -> t option
96
+
(** [of_assistant msg] returns Some if assistant has error, None otherwise. *)
97
+
end
98
+
99
+
module Complete : sig
100
+
(** Session completion event with final results. *)
101
+
102
+
type t
103
+
(** The type of completion response events (opaque). *)
104
+
105
+
val duration_ms : t -> int
106
+
(** [duration_ms t] returns the total duration in milliseconds. *)
107
+
108
+
val num_turns : t -> int
109
+
(** [num_turns t] returns the number of conversation turns. *)
110
+
111
+
val session_id : t -> string
112
+
(** [session_id t] returns the session identifier. *)
113
+
114
+
val total_cost_usd : t -> float option
115
+
(** [total_cost_usd t] returns the optional total cost in USD. *)
116
+
117
+
val usage : t -> Message.Result.Usage.t option
118
+
(** [usage t] returns the optional usage statistics. *)
119
+
120
+
val result_text : t -> string option
121
+
(** [result_text t] returns the optional result string. *)
122
+
123
+
val structured_output : t -> Jsont.json option
124
+
(** [structured_output t] returns the optional structured JSON output. *)
125
+
126
+
val of_result : Message.Result.t -> t
127
+
(** [of_result result] creates a completion response from a result message. *)
128
+
end
129
+
130
+
(** {1 Response Event Union Type} *)
131
+
132
+
type t =
133
+
| Text of Text.t (** Text content from assistant *)
134
+
| Tool_use of Tool_use.t (** Tool invocation request *)
135
+
| Tool_result of Content_block.Tool_result.t (** Tool result (pass-through) *)
136
+
| Thinking of Thinking.t (** Internal reasoning *)
137
+
| Init of Init.t (** Session initialization *)
138
+
| Error of Error.t (** Error event *)
139
+
| Complete of Complete.t (** Session completion *)
140
+
(** The type of response events that can be received from Claude. *)
141
+
142
+
(** {1 Conversion} *)
143
+
144
+
val of_message : Message.t -> t list
145
+
(** [of_message msg] converts a message to response events. An assistant
146
+
message may produce multiple events (one per content block). User messages
147
+
produce empty lists since they are not responses. *)
+4
-4
lib/sdk_control.ml
+4
-4
lib/sdk_control.ml
···
10
10
subtype : [ `Can_use_tool ];
11
11
tool_name : string;
12
12
input : Jsont.json;
13
-
permission_suggestions : Permissions.Update.t list option;
13
+
permission_suggestions : Proto.Permissions.Update.t list option;
14
14
blocked_path : string option;
15
15
unknown : Unknown.t;
16
16
}
···
23
23
24
24
type set_permission_mode = {
25
25
subtype : [ `Set_permission_mode ];
26
-
mode : Permissions.Mode.t;
26
+
mode : Proto.Permissions.Mode.t;
27
27
unknown : Unknown.t;
28
28
}
29
29
···
123
123
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : permission) ->
124
124
r.input)
125
125
|> Jsont.Object.opt_mem "permission_suggestions"
126
-
(Jsont.list Permissions.Update.jsont) ~enc:(fun (r : permission) ->
126
+
(Jsont.list Proto.Permissions.Update.jsont) ~enc:(fun (r : permission) ->
127
127
r.permission_suggestions)
128
128
|> Jsont.Object.opt_mem "blocked_path" Jsont.string
129
129
~enc:(fun (r : permission) -> r.blocked_path)
···
156
156
{ subtype = `Set_permission_mode; mode; unknown }
157
157
in
158
158
Jsont.Object.map ~kind:"SetPermissionMode" make
159
-
|> Jsont.Object.mem "mode" Permissions.Mode.jsont
159
+
|> Jsont.Object.mem "mode" Proto.Permissions.Mode.jsont
160
160
~enc:(fun (r : set_permission_mode) -> r.mode)
161
161
|> Jsont.Object.keep_unknown Jsont.json_mems
162
162
~enc:(fun (r : set_permission_mode) -> r.unknown)
+4
-4
lib/sdk_control.mli
+4
-4
lib/sdk_control.mli
···
66
66
subtype : [ `Can_use_tool ];
67
67
tool_name : string;
68
68
input : Jsont.json;
69
-
permission_suggestions : Permissions.Update.t list option;
69
+
permission_suggestions : Proto.Permissions.Update.t list option;
70
70
blocked_path : string option;
71
71
unknown : Unknown.t;
72
72
}
···
81
81
82
82
type set_permission_mode = {
83
83
subtype : [ `Set_permission_mode ];
84
-
mode : Permissions.Mode.t;
84
+
mode : Proto.Permissions.Mode.t;
85
85
unknown : Unknown.t;
86
86
}
87
87
(** Request to change permission mode. *)
···
130
130
val permission :
131
131
tool_name:string ->
132
132
input:Jsont.json ->
133
-
?permission_suggestions:Permissions.Update.t list ->
133
+
?permission_suggestions:Proto.Permissions.Update.t list ->
134
134
?blocked_path:string ->
135
135
?unknown:Unknown.t ->
136
136
unit ->
···
143
143
(** [initialize ?hooks ?unknown ()] creates an initialize request. *)
144
144
145
145
val set_permission_mode :
146
-
mode:Permissions.Mode.t -> ?unknown:Unknown.t -> unit -> t
146
+
mode:Proto.Permissions.Mode.t -> ?unknown:Unknown.t -> unit -> t
147
147
(** [set_permission_mode ~mode ?unknown] creates a permission mode change
148
148
request. *)
149
149
lib/server_info.cmi
lib/server_info.cmi
This is a binary file and will not be displayed.
+35
lib/server_info.ml
+35
lib/server_info.ml
···
1
+
(** Server capabilities and metadata. *)
2
+
3
+
type t = {
4
+
version : string;
5
+
capabilities : string list;
6
+
commands : string list;
7
+
output_styles : string list;
8
+
}
9
+
10
+
let version t = t.version
11
+
let capabilities t = t.capabilities
12
+
let commands t = t.commands
13
+
let output_styles t = t.output_styles
14
+
15
+
let has_capability t cap = List.mem cap t.capabilities
16
+
17
+
let supports_hooks t = has_capability t "hooks"
18
+
19
+
let supports_structured_output t = has_capability t "structured-output"
20
+
21
+
let of_proto (proto : Proto.Control.Server_info.t) : t =
22
+
{
23
+
version = Proto.Control.Server_info.version proto;
24
+
capabilities = Proto.Control.Server_info.capabilities proto;
25
+
commands = Proto.Control.Server_info.commands proto;
26
+
output_styles = Proto.Control.Server_info.output_styles proto;
27
+
}
28
+
29
+
let of_sdk_control (sdk : Sdk_control.Server_info.t) : t =
30
+
{
31
+
version = Sdk_control.Server_info.version sdk;
32
+
capabilities = Sdk_control.Server_info.capabilities sdk;
33
+
commands = Sdk_control.Server_info.commands sdk;
34
+
output_styles = Sdk_control.Server_info.output_styles sdk;
35
+
}
+43
lib/server_info.mli
+43
lib/server_info.mli
···
1
+
(** Server capabilities and metadata.
2
+
3
+
This module provides a high-level interface for querying server capabilities
4
+
and metadata. It wraps the underlying protocol representation and provides
5
+
convenient accessors and capability checks. *)
6
+
7
+
(** {1 Server Information} *)
8
+
9
+
type t
10
+
(** Server metadata and capabilities. *)
11
+
12
+
val version : t -> string
13
+
(** [version t] returns the server version string. *)
14
+
15
+
val capabilities : t -> string list
16
+
(** [capabilities t] returns the list of available server capabilities. *)
17
+
18
+
val commands : t -> string list
19
+
(** [commands t] returns the list of available CLI commands. *)
20
+
21
+
val output_styles : t -> string list
22
+
(** [output_styles t] returns the list of supported output formats. *)
23
+
24
+
(** {1 Capability Checks} *)
25
+
26
+
val has_capability : t -> string -> bool
27
+
(** [has_capability t cap] returns true if the specified capability is
28
+
available. *)
29
+
30
+
val supports_hooks : t -> bool
31
+
(** [supports_hooks t] checks if the hooks capability is available. *)
32
+
33
+
val supports_structured_output : t -> bool
34
+
(** [supports_structured_output t] checks if the structured output capability
35
+
is available. *)
36
+
37
+
(** {1 Internal} *)
38
+
39
+
val of_proto : Proto.Control.Server_info.t -> t
40
+
(** [of_proto proto] converts from the protocol representation. *)
41
+
42
+
val of_sdk_control : Sdk_control.Server_info.t -> t
43
+
(** [of_sdk_control sdk] converts from the SDK control representation. *)
+144
lib/tool_input.ml
+144
lib/tool_input.ml
···
1
+
(** Opaque tool input with typed accessors. *)
2
+
3
+
type t = Jsont.json
4
+
5
+
(** {1 Escape Hatch} *)
6
+
7
+
let to_json t = t
8
+
let of_json json = json
9
+
10
+
(** {1 Helper Functions} *)
11
+
12
+
(* Extract members from JSON object, or return empty list if not an object *)
13
+
let get_members = function
14
+
| Jsont.Object (members, _) -> members
15
+
| _ -> []
16
+
17
+
(* Find a member by key in the object *)
18
+
let find_member key members =
19
+
List.find_map
20
+
(fun ((name, _), value) -> if name = key then Some value else None)
21
+
members
22
+
23
+
(** {1 Typed Accessors} *)
24
+
25
+
let get_string t key =
26
+
let members = get_members t in
27
+
match find_member key members with
28
+
| Some json -> (
29
+
match Jsont.Json.decode Jsont.string json with
30
+
| Ok s -> Some s
31
+
| Error _ -> None)
32
+
| None -> None
33
+
34
+
let get_int t key =
35
+
let members = get_members t in
36
+
match find_member key members with
37
+
| Some json -> (
38
+
match Jsont.Json.decode Jsont.int json with
39
+
| Ok i -> Some i
40
+
| Error _ -> None)
41
+
| None -> None
42
+
43
+
let get_bool t key =
44
+
let members = get_members t in
45
+
match find_member key members with
46
+
| Some json -> (
47
+
match Jsont.Json.decode Jsont.bool json with
48
+
| Ok b -> Some b
49
+
| Error _ -> None)
50
+
| None -> None
51
+
52
+
let get_float t key =
53
+
let members = get_members t in
54
+
match find_member key members with
55
+
| Some json -> (
56
+
match Jsont.Json.decode Jsont.number json with
57
+
| Ok f -> Some f
58
+
| Error _ -> None)
59
+
| None -> None
60
+
61
+
let get_string_list t key =
62
+
let members = get_members t in
63
+
match find_member key members with
64
+
| Some json -> (
65
+
match json with
66
+
| Jsont.Array (items, _) ->
67
+
let strings =
68
+
List.filter_map
69
+
(fun item ->
70
+
match Jsont.Json.decode Jsont.string item with
71
+
| Ok s -> Some s
72
+
| Error _ -> None)
73
+
items
74
+
in
75
+
(* Only return Some if all items were strings *)
76
+
if List.length strings = List.length items then Some strings else None
77
+
| _ -> None)
78
+
| None -> None
79
+
80
+
let keys t =
81
+
let members = get_members t in
82
+
List.map (fun ((name, _), _) -> name) members
83
+
84
+
let is_empty t =
85
+
match t with Jsont.Object ([], _) -> true | Jsont.Object _ -> false | _ -> true
86
+
87
+
(** {1 Construction} *)
88
+
89
+
let empty = Jsont.Object ([], Jsont.Meta.none)
90
+
91
+
let add_member key value t =
92
+
let members = get_members t in
93
+
let new_member = ((key, Jsont.Meta.none), value) in
94
+
(* Replace existing member or add new one *)
95
+
let filtered_members =
96
+
List.filter (fun ((name, _), _) -> name <> key) members
97
+
in
98
+
Jsont.Object (new_member :: filtered_members, Jsont.Meta.none)
99
+
100
+
let add_string key value t =
101
+
let json_value =
102
+
match Jsont.Json.encode Jsont.string value with
103
+
| Ok json -> json
104
+
| Error _ -> failwith "add_string: encoding failed"
105
+
in
106
+
add_member key json_value t
107
+
108
+
let add_int key value t =
109
+
let json_value =
110
+
match Jsont.Json.encode Jsont.int value with
111
+
| Ok json -> json
112
+
| Error _ -> failwith "add_int: encoding failed"
113
+
in
114
+
add_member key json_value t
115
+
116
+
let add_bool key value t =
117
+
let json_value =
118
+
match Jsont.Json.encode Jsont.bool value with
119
+
| Ok json -> json
120
+
| Error _ -> failwith "add_bool: encoding failed"
121
+
in
122
+
add_member key json_value t
123
+
124
+
let add_float key value t =
125
+
let json_value =
126
+
match Jsont.Json.encode Jsont.number value with
127
+
| Ok json -> json
128
+
| Error _ -> failwith "add_float: encoding failed"
129
+
in
130
+
add_member key json_value t
131
+
132
+
let of_assoc assoc =
133
+
let members =
134
+
List.map (fun (key, json) -> ((key, Jsont.Meta.none), json)) assoc
135
+
in
136
+
Jsont.Object (members, Jsont.Meta.none)
137
+
138
+
let of_string_pairs pairs =
139
+
let assoc =
140
+
List.map
141
+
(fun (key, value) -> (key, Jsont.String (value, Jsont.Meta.none)))
142
+
pairs
143
+
in
144
+
of_assoc assoc
+64
lib/tool_input.mli
+64
lib/tool_input.mli
···
1
+
(** Opaque tool input with typed accessors.
2
+
3
+
Tool inputs are JSON objects representing parameters passed to tools. This
4
+
module provides type-safe accessors while hiding the JSON structure from
5
+
most client code. *)
6
+
7
+
type t
8
+
(** Abstract type for tool inputs. *)
9
+
10
+
(** {1 Typed Accessors} *)
11
+
12
+
val get_string : t -> string -> string option
13
+
(** [get_string t key] returns the string value for [key], if present and a
14
+
string. *)
15
+
16
+
val get_int : t -> string -> int option
17
+
(** [get_int t key] returns the integer value for [key], if present and an int. *)
18
+
19
+
val get_bool : t -> string -> bool option
20
+
(** [get_bool t key] returns the boolean value for [key], if present and a bool. *)
21
+
22
+
val get_float : t -> string -> float option
23
+
(** [get_float t key] returns the float value for [key], if present and a float. *)
24
+
25
+
val get_string_list : t -> string -> string list option
26
+
(** [get_string_list t key] returns the string list for [key], if present and a
27
+
list of strings. *)
28
+
29
+
val keys : t -> string list
30
+
(** [keys t] returns all keys in the input. *)
31
+
32
+
val is_empty : t -> bool
33
+
(** [is_empty t] returns true if the input has no keys. *)
34
+
35
+
(** {1 Escape Hatch} *)
36
+
37
+
val to_json : t -> Jsont.json
38
+
(** [to_json t] returns the underlying JSON for advanced use cases. *)
39
+
40
+
val of_json : Jsont.json -> t
41
+
(** [of_json json] wraps JSON as a tool input. *)
42
+
43
+
(** {1 Construction} *)
44
+
45
+
val empty : t
46
+
(** [empty] is an empty tool input. *)
47
+
48
+
val add_string : string -> string -> t -> t
49
+
(** [add_string key value t] adds a string field. *)
50
+
51
+
val add_int : string -> int -> t -> t
52
+
(** [add_int key value t] adds an integer field. *)
53
+
54
+
val add_bool : string -> bool -> t -> t
55
+
(** [add_bool key value t] adds a boolean field. *)
56
+
57
+
val add_float : string -> float -> t -> t
58
+
(** [add_float key value t] adds a float field. *)
59
+
60
+
val of_assoc : (string * Jsont.json) list -> t
61
+
(** [of_assoc assoc] creates tool input from an association list. *)
62
+
63
+
val of_string_pairs : (string * string) list -> t
64
+
(** [of_string_pairs pairs] creates tool input from string key-value pairs. *)
+11
-36
lib/transport.ml
+11
-36
lib/transport.ml
···
18
18
}
19
19
20
20
let setting_source_to_string = function
21
-
| Options.User -> "user"
22
-
| Options.Project -> "project"
23
-
| Options.Local -> "local"
21
+
| Proto.Options.User -> "user"
22
+
| Proto.Options.Project -> "project"
23
+
| Proto.Options.Local -> "local"
24
24
25
25
let build_command ~claude_path ~options =
26
26
let cmd = [ claude_path; "--output-format"; "stream-json"; "--verbose" ] in
···
96
96
let cmd =
97
97
match Options.output_format options with
98
98
| Some format ->
99
-
let schema = Structured_output.json_schema format in
99
+
let schema = Proto.Structured_output.to_json_schema format in
100
100
let schema_str =
101
101
match Jsont_bytesrw.encode_string' Jsont.json schema with
102
102
| Ok s -> s
···
230
230
(Printf.sprintf "Failed to receive message: %s"
231
231
(Printexc.to_string exn)))
232
232
233
-
(** Wire codec for interrupt response messages. *)
234
-
module Interrupt_wire = struct
235
-
type inner = { subtype : string; request_id : string }
236
-
type t = { type_ : string; response : inner }
237
-
238
-
let inner_jsont : inner Jsont.t =
239
-
let make subtype request_id = { subtype; request_id } in
240
-
Jsont.Object.map ~kind:"InterruptInner" make
241
-
|> Jsont.Object.mem "subtype" Jsont.string ~enc:(fun r -> r.subtype)
242
-
|> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun r -> r.request_id)
243
-
|> Jsont.Object.finish
244
-
245
-
let jsont : t Jsont.t =
246
-
let make type_ response = { type_; response } in
247
-
Jsont.Object.map ~kind:"InterruptOuter" make
248
-
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun r -> r.type_)
249
-
|> Jsont.Object.mem "response" inner_jsont ~enc:(fun r -> r.response)
250
-
|> Jsont.Object.finish
251
-
252
-
let encode () =
253
-
let wire =
254
-
{
255
-
type_ = "control_response";
256
-
response = { subtype = "interrupt"; request_id = "" };
257
-
}
258
-
in
259
-
match Jsont.Json.encode jsont wire with
260
-
| Ok json -> json
261
-
| Error msg -> failwith ("Interrupt_wire.encode: " ^ msg)
262
-
end
263
-
264
233
let interrupt t =
265
234
Log.info (fun m -> m "Sending interrupt signal");
266
-
let interrupt_msg = Interrupt_wire.encode () in
235
+
(* Create interrupt request using Proto types *)
236
+
let request = Proto.Control.Request.interrupt () in
237
+
let envelope =
238
+
Proto.Control.create_request ~request_id:"" ~request ()
239
+
in
240
+
let outgoing = Proto.Outgoing.Control_request envelope in
241
+
let interrupt_msg = Proto.Outgoing.to_json outgoing in
267
242
send t interrupt_msg
268
243
269
244
let close t =
+131
proto/content_block.ml
+131
proto/content_block.ml
···
1
+
module Text = struct
2
+
type t = { text : string; unknown : Unknown.t }
3
+
4
+
let create text = { text; unknown = Unknown.empty }
5
+
let make text unknown = { text; unknown }
6
+
let text t = t.text
7
+
let unknown t = t.unknown
8
+
9
+
let jsont : t Jsont.t =
10
+
Jsont.Object.map ~kind:"Text" make
11
+
|> Jsont.Object.mem "text" Jsont.string ~enc:text
12
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
13
+
|> Jsont.Object.finish
14
+
end
15
+
16
+
module Tool_use = struct
17
+
type t = { id : string; name : string; input : Jsont.json; unknown : Unknown.t }
18
+
19
+
let create ~id ~name ~input = { id; name; input; unknown = Unknown.empty }
20
+
let make id name input unknown = { id; name; input; unknown }
21
+
let id t = t.id
22
+
let name t = t.name
23
+
let input t = t.input
24
+
let unknown t = t.unknown
25
+
26
+
let jsont : t Jsont.t =
27
+
Jsont.Object.map ~kind:"Tool_use" make
28
+
|> Jsont.Object.mem "id" Jsont.string ~enc:id
29
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
30
+
|> Jsont.Object.mem "input" Jsont.json ~enc:input
31
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
32
+
|> Jsont.Object.finish
33
+
end
34
+
35
+
module Tool_result = struct
36
+
type t = {
37
+
tool_use_id : string;
38
+
content : string option;
39
+
is_error : bool option;
40
+
unknown : Unknown.t;
41
+
}
42
+
43
+
let create ~tool_use_id ?content ?is_error () =
44
+
{ tool_use_id; content; is_error; unknown = Unknown.empty }
45
+
46
+
let make tool_use_id content is_error unknown =
47
+
{ tool_use_id; content; is_error; unknown }
48
+
49
+
let tool_use_id t = t.tool_use_id
50
+
let content t = t.content
51
+
let is_error t = t.is_error
52
+
let unknown t = t.unknown
53
+
54
+
let jsont : t Jsont.t =
55
+
Jsont.Object.map ~kind:"Tool_result" make
56
+
|> Jsont.Object.mem "tool_use_id" Jsont.string ~enc:tool_use_id
57
+
|> Jsont.Object.opt_mem "content" Jsont.string ~enc:content
58
+
|> Jsont.Object.opt_mem "is_error" Jsont.bool ~enc:is_error
59
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
60
+
|> Jsont.Object.finish
61
+
end
62
+
63
+
module Thinking = struct
64
+
type t = { thinking : string; signature : string; unknown : Unknown.t }
65
+
66
+
let create ~thinking ~signature =
67
+
{ thinking; signature; unknown = Unknown.empty }
68
+
69
+
let make thinking signature unknown = { thinking; signature; unknown }
70
+
let thinking t = t.thinking
71
+
let signature t = t.signature
72
+
let unknown t = t.unknown
73
+
74
+
let jsont : t Jsont.t =
75
+
Jsont.Object.map ~kind:"Thinking" make
76
+
|> Jsont.Object.mem "thinking" Jsont.string ~enc:thinking
77
+
|> Jsont.Object.mem "signature" Jsont.string ~enc:signature
78
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
79
+
|> Jsont.Object.finish
80
+
end
81
+
82
+
type t =
83
+
| Text of Text.t
84
+
| Tool_use of Tool_use.t
85
+
| Tool_result of Tool_result.t
86
+
| Thinking of Thinking.t
87
+
88
+
let text s = Text (Text.create s)
89
+
let tool_use ~id ~name ~input = Tool_use (Tool_use.create ~id ~name ~input)
90
+
91
+
let tool_result ~tool_use_id ?content ?is_error () =
92
+
Tool_result (Tool_result.create ~tool_use_id ?content ?is_error ())
93
+
94
+
let thinking ~thinking ~signature =
95
+
Thinking (Thinking.create ~thinking ~signature)
96
+
97
+
let jsont : t Jsont.t =
98
+
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
99
+
100
+
let case_text = case_map "text" Text.jsont (fun v -> Text v) in
101
+
let case_tool_use =
102
+
case_map "tool_use" Tool_use.jsont (fun v -> Tool_use v)
103
+
in
104
+
let case_tool_result =
105
+
case_map "tool_result" Tool_result.jsont (fun v -> Tool_result v)
106
+
in
107
+
let case_thinking =
108
+
case_map "thinking" Thinking.jsont (fun v -> Thinking v)
109
+
in
110
+
111
+
let enc_case = function
112
+
| Text v -> Jsont.Object.Case.value case_text v
113
+
| Tool_use v -> Jsont.Object.Case.value case_tool_use v
114
+
| Tool_result v -> Jsont.Object.Case.value case_tool_result v
115
+
| Thinking v -> Jsont.Object.Case.value case_thinking v
116
+
in
117
+
118
+
let cases =
119
+
Jsont.Object.Case.
120
+
[
121
+
make case_text;
122
+
make case_tool_use;
123
+
make case_tool_result;
124
+
make case_thinking;
125
+
]
126
+
in
127
+
128
+
Jsont.Object.map ~kind:"Content_block" Fun.id
129
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
130
+
~tag_to_string:Fun.id ~tag_compare:String.compare
131
+
|> Jsont.Object.finish
+131
proto/content_block.ml.bak
+131
proto/content_block.ml.bak
···
1
+
module Text = struct
2
+
type t = { text : string; unknown : Unknown.t }
3
+
4
+
let create text = { text; unknown = Unknown.empty }
5
+
let make text unknown = { text; unknown }
6
+
let text t = t.text
7
+
let unknown t = t.unknown
8
+
9
+
let jsont : t Jsont.t =
10
+
Jsont.Object.map ~kind:"Text" make
11
+
|> Jsont.Object.mem "text" Jsont.string ~enc:text
12
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
13
+
|> Jsont.Object.finish
14
+
end
15
+
16
+
module Tool_use = struct
17
+
type t = { id : string; name : string; input : Jsont.json; unknown : Unknown.t }
18
+
19
+
let create ~id ~name ~input = { id; name; input; unknown = Unknown.empty }
20
+
let make id name input unknown = { id; name; input; unknown }
21
+
let id t = t.id
22
+
let name t = t.name
23
+
let input t = t.input
24
+
let unknown t = t.unknown
25
+
26
+
let jsont : t Jsont.t =
27
+
Jsont.Object.map ~kind:"Tool_use" make
28
+
|> Jsont.Object.mem "id" Jsont.string ~enc:id
29
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
30
+
|> Jsont.Object.mem "input" Jsont.json ~enc:input
31
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
32
+
|> Jsont.Object.finish
33
+
end
34
+
35
+
module Tool_result = struct
36
+
type t = {
37
+
tool_use_id : string;
38
+
content : string option;
39
+
is_error : bool option;
40
+
unknown : Unknown.t;
41
+
}
42
+
43
+
let create ~tool_use_id ?content ?is_error () =
44
+
{ tool_use_id; content; is_error; unknown = Unknown.empty }
45
+
46
+
let make tool_use_id content is_error unknown =
47
+
{ tool_use_id; content; is_error; unknown }
48
+
49
+
let tool_use_id t = t.tool_use_id
50
+
let content t = t.content
51
+
let is_error t = t.is_error
52
+
let unknown t = t.unknown
53
+
54
+
let jsont : t Jsont.t =
55
+
Jsont.Object.map ~kind:"Tool_result" make
56
+
|> Jsont.Object.mem "tool_use_id" Jsont.string ~enc:tool_use_id
57
+
|> Jsont.Object.opt_mem "content" Jsont.string ~enc:content
58
+
|> Jsont.Object.opt_mem "is_error" Jsont.bool ~enc:is_error
59
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
60
+
|> Jsont.Object.finish
61
+
end
62
+
63
+
module Thinking = struct
64
+
type t = { thinking : string; signature : string; unknown : Unknown.t }
65
+
66
+
let create ~thinking ~signature =
67
+
{ thinking; signature; unknown = Unknown.empty }
68
+
69
+
let make thinking signature unknown = { thinking; signature; unknown }
70
+
let thinking t = t.thinking
71
+
let signature t = t.signature
72
+
let unknown t = t.unknown
73
+
74
+
let jsont : t Jsont.t =
75
+
Jsont.Object.map ~kind:"Thinking" make
76
+
|> Jsont.Object.mem "thinking" Jsont.string ~enc:thinking
77
+
|> Jsont.Object.mem "signature" Jsont.string ~enc:signature
78
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
79
+
|> Jsont.Object.finish
80
+
end
81
+
82
+
type t =
83
+
| Text of Text.t
84
+
| Tool_use of Tool_use.t
85
+
| Tool_result of Tool_result.t
86
+
| Thinking of Thinking.t
87
+
88
+
let text s = Text (Text.create s)
89
+
let tool_use ~id ~name ~input = Tool_use (Tool_use.create ~id ~name ~input)
90
+
91
+
let tool_result ~tool_use_id ?content ?is_error () =
92
+
Tool_result (Tool_result.create ~tool_use_id ?content ?is_error ())
93
+
94
+
let thinking ~thinking ~signature =
95
+
Thinking (Thinking.create ~thinking ~signature)
96
+
97
+
let jsont : t Jsont.t =
98
+
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
99
+
100
+
let case_text = case_map "text" Text.jsont (fun v -> Text v) in
101
+
let case_tool_use =
102
+
case_map "tool_use" Tool_use.jsont (fun v -> Tool_use v)
103
+
in
104
+
let case_tool_result =
105
+
case_map "tool_result" Tool_result.jsont (fun v -> Tool_result v)
106
+
in
107
+
let case_thinking =
108
+
case_map "thinking" Thinking.jsont (fun v -> Thinking v)
109
+
in
110
+
111
+
let enc_case = function
112
+
| Text v -> Jsont.Object.Case.value case_text v
113
+
| Tool_use v -> Jsont.Object.Case.value case_tool_use v
114
+
| Tool_result v -> Jsont.Object.Case.value case_tool_result v
115
+
| Thinking v -> Jsont.Object.Case.value case_thinking v
116
+
in
117
+
118
+
let cases =
119
+
Jsont.Object.Case.
120
+
[
121
+
make case_text;
122
+
make case_tool_use;
123
+
make case_tool_result;
124
+
make case_thinking;
125
+
]
126
+
in
127
+
128
+
Jsont.Object.map ~kind:"Content_block" Fun.id
129
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
130
+
~tag_to_string:Fun.id ~tag_compare:String.compare
131
+
|> Jsont.Object.finish
+151
proto/content_block.mli
+151
proto/content_block.mli
···
1
+
(** Content blocks for Claude messages wire format.
2
+
3
+
This module defines the wire format types for content blocks that can appear
4
+
in Claude messages, including text, tool use, tool results, and thinking
5
+
blocks. *)
6
+
7
+
(** {1 Text Blocks} *)
8
+
9
+
module Text : sig
10
+
(** Plain text content blocks. *)
11
+
12
+
type t
13
+
(** The type of text blocks. *)
14
+
15
+
val jsont : t Jsont.t
16
+
(** [jsont] is the Jsont codec for text blocks. Use [Jsont.Json.encode jsont]
17
+
and [Jsont.Json.decode jsont] for serialization. Use
18
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
19
+
20
+
val create : string -> t
21
+
(** [create text] creates a new text block with the given text content. *)
22
+
23
+
val text : t -> string
24
+
(** [text t] returns the text content of the block. *)
25
+
26
+
val unknown : t -> Unknown.t
27
+
(** [unknown t] returns any unknown fields from JSON parsing. *)
28
+
end
29
+
30
+
(** {1 Tool Use Blocks} *)
31
+
32
+
module Tool_use : sig
33
+
(** Tool invocation requests from the assistant. *)
34
+
35
+
type t
36
+
(** The type of tool use blocks. *)
37
+
38
+
val jsont : t Jsont.t
39
+
(** [jsont] is the Jsont codec for tool use blocks. Use
40
+
[Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
41
+
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
42
+
43
+
val create : id:string -> name:string -> input:Jsont.json -> t
44
+
(** [create ~id ~name ~input] creates a new tool use block.
45
+
@param id Unique identifier for this tool invocation
46
+
@param name Name of the tool to invoke
47
+
@param input Parameters for the tool as raw JSON *)
48
+
49
+
val id : t -> string
50
+
(** [id t] returns the unique identifier of the tool use. *)
51
+
52
+
val name : t -> string
53
+
(** [name t] returns the name of the tool being invoked. *)
54
+
55
+
val input : t -> Jsont.json
56
+
(** [input t] returns the input parameters for the tool as raw JSON. *)
57
+
58
+
val unknown : t -> Unknown.t
59
+
(** [unknown t] returns any unknown fields from JSON parsing. *)
60
+
end
61
+
62
+
(** {1 Tool Result Blocks} *)
63
+
64
+
module Tool_result : sig
65
+
(** Results from tool invocations. *)
66
+
67
+
type t
68
+
(** The type of tool result blocks. *)
69
+
70
+
val jsont : t Jsont.t
71
+
(** [jsont] is the Jsont codec for tool result blocks. Use
72
+
[Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
73
+
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
74
+
75
+
val create :
76
+
tool_use_id:string -> ?content:string -> ?is_error:bool -> unit -> t
77
+
(** [create ~tool_use_id ?content ?is_error ()] creates a new tool result
78
+
block.
79
+
@param tool_use_id The ID of the corresponding tool use block
80
+
@param content Optional result content
81
+
@param is_error Whether the tool execution resulted in an error *)
82
+
83
+
val tool_use_id : t -> string
84
+
(** [tool_use_id t] returns the ID of the corresponding tool use. *)
85
+
86
+
val content : t -> string option
87
+
(** [content t] returns the optional result content. *)
88
+
89
+
val is_error : t -> bool option
90
+
(** [is_error t] returns whether this result represents an error. *)
91
+
92
+
val unknown : t -> Unknown.t
93
+
(** [unknown t] returns any unknown fields from JSON parsing. *)
94
+
end
95
+
96
+
(** {1 Thinking Blocks} *)
97
+
98
+
module Thinking : sig
99
+
(** Assistant's internal reasoning blocks. *)
100
+
101
+
type t
102
+
(** The type of thinking blocks. *)
103
+
104
+
val jsont : t Jsont.t
105
+
(** [jsont] is the Jsont codec for thinking blocks. Use
106
+
[Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
107
+
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
108
+
109
+
val create : thinking:string -> signature:string -> t
110
+
(** [create ~thinking ~signature] creates a new thinking block.
111
+
@param thinking The assistant's internal reasoning
112
+
@param signature Cryptographic signature for verification *)
113
+
114
+
val thinking : t -> string
115
+
(** [thinking t] returns the thinking content. *)
116
+
117
+
val signature : t -> string
118
+
(** [signature t] returns the cryptographic signature. *)
119
+
120
+
val unknown : t -> Unknown.t
121
+
(** [unknown t] returns any unknown fields from JSON parsing. *)
122
+
end
123
+
124
+
(** {1 Content Block Union Type} *)
125
+
126
+
type t =
127
+
| Text of Text.t
128
+
| Tool_use of Tool_use.t
129
+
| Tool_result of Tool_result.t
130
+
| Thinking of Thinking.t
131
+
(** The type of content blocks, which can be text, tool use, tool result,
132
+
or thinking. *)
133
+
134
+
val jsont : t Jsont.t
135
+
(** [jsont] is the Jsont codec for content blocks. Use [Jsont.Json.encode jsont]
136
+
and [Jsont.Json.decode jsont] for serialization. Use
137
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
138
+
139
+
val text : string -> t
140
+
(** [text s] creates a text content block. *)
141
+
142
+
val tool_use : id:string -> name:string -> input:Jsont.json -> t
143
+
(** [tool_use ~id ~name ~input] creates a tool use content block. *)
144
+
145
+
val tool_result :
146
+
tool_use_id:string -> ?content:string -> ?is_error:bool -> unit -> t
147
+
(** [tool_result ~tool_use_id ?content ?is_error ()] creates a tool result
148
+
content block. *)
149
+
150
+
val thinking : thinking:string -> signature:string -> t
151
+
(** [thinking ~thinking ~signature] creates a thinking content block. *)
+346
proto/control.ml
+346
proto/control.ml
···
1
+
(** Control protocol wire format for SDK communication. *)
2
+
3
+
module Request = struct
4
+
(* Individual record types for each request variant - private to this module *)
5
+
type permission_r = {
6
+
tool_name : string;
7
+
input : Jsont.json;
8
+
permission_suggestions : Permissions.Update.t list option;
9
+
blocked_path : string option;
10
+
unknown : Unknown.t;
11
+
}
12
+
13
+
type initialize_r = {
14
+
hooks : (string * Jsont.json) list option;
15
+
unknown : Unknown.t;
16
+
}
17
+
18
+
type set_permission_mode_r = {
19
+
mode : Permissions.Mode.t;
20
+
unknown : Unknown.t;
21
+
}
22
+
23
+
type hook_callback_r = {
24
+
callback_id : string;
25
+
input : Jsont.json;
26
+
tool_use_id : string option;
27
+
unknown : Unknown.t;
28
+
}
29
+
30
+
type mcp_message_r = {
31
+
server_name : string;
32
+
message : Jsont.json;
33
+
unknown : Unknown.t;
34
+
}
35
+
36
+
type set_model_r = { model : string; unknown : Unknown.t }
37
+
38
+
type t =
39
+
| Interrupt
40
+
| Permission of permission_r
41
+
| Initialize of initialize_r
42
+
| Set_permission_mode of set_permission_mode_r
43
+
| Hook_callback of hook_callback_r
44
+
| Mcp_message of mcp_message_r
45
+
| Set_model of set_model_r
46
+
| Get_server_info
47
+
48
+
let interrupt () = Interrupt
49
+
50
+
let permission ~tool_name ~input ?permission_suggestions ?blocked_path () =
51
+
Permission
52
+
{
53
+
tool_name;
54
+
input;
55
+
permission_suggestions;
56
+
blocked_path;
57
+
unknown = Unknown.empty;
58
+
}
59
+
60
+
let initialize ?hooks () = Initialize { hooks; unknown = Unknown.empty }
61
+
62
+
let set_permission_mode ~mode () =
63
+
Set_permission_mode { mode; unknown = Unknown.empty }
64
+
65
+
let hook_callback ~callback_id ~input ?tool_use_id () =
66
+
Hook_callback
67
+
{ callback_id; input; tool_use_id; unknown = Unknown.empty }
68
+
69
+
let mcp_message ~server_name ~message () =
70
+
Mcp_message { server_name; message; unknown = Unknown.empty }
71
+
72
+
let set_model ~model () = Set_model { model; unknown = Unknown.empty }
73
+
let get_server_info () = Get_server_info
74
+
75
+
(* Individual record codecs *)
76
+
let interrupt_jsont : unit Jsont.t =
77
+
Jsont.Object.map ~kind:"Interrupt" (fun _unknown -> ())
78
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun () -> Unknown.empty)
79
+
|> Jsont.Object.finish
80
+
81
+
let permission_jsont : permission_r Jsont.t =
82
+
let make tool_name input permission_suggestions blocked_path unknown :
83
+
permission_r =
84
+
{ tool_name; input; permission_suggestions; blocked_path; unknown }
85
+
in
86
+
(Jsont.Object.map ~kind:"Permission" make
87
+
|> Jsont.Object.mem "toolName" Jsont.string
88
+
~enc:(fun (r : permission_r) -> r.tool_name)
89
+
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : permission_r) -> r.input)
90
+
|> Jsont.Object.opt_mem "permissionSuggestions"
91
+
(Jsont.list Permissions.Update.jsont) ~enc:(fun (r : permission_r) ->
92
+
r.permission_suggestions)
93
+
|> Jsont.Object.opt_mem "blockedPath" Jsont.string ~enc:(fun (r : permission_r) ->
94
+
r.blocked_path)
95
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : permission_r) -> r.unknown)
96
+
|> Jsont.Object.finish)
97
+
98
+
let initialize_jsont : initialize_r Jsont.t =
99
+
(* The hooks field is an object with string keys and json values *)
100
+
let hooks_map_jsont = Jsont.Object.as_string_map Jsont.json in
101
+
let module StringMap = Map.Make (String) in
102
+
let hooks_jsont =
103
+
Jsont.map
104
+
~dec:(fun m -> StringMap.bindings m)
105
+
~enc:(fun l -> StringMap.of_seq (List.to_seq l))
106
+
hooks_map_jsont
107
+
in
108
+
let make hooks unknown = { hooks; unknown } in
109
+
(Jsont.Object.map ~kind:"Initialize" make
110
+
|> Jsont.Object.opt_mem "hooks" hooks_jsont ~enc:(fun (r : initialize_r) -> r.hooks)
111
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : initialize_r) -> r.unknown)
112
+
|> Jsont.Object.finish)
113
+
114
+
let set_permission_mode_jsont : set_permission_mode_r Jsont.t =
115
+
let make mode unknown = { mode; unknown } in
116
+
(Jsont.Object.map ~kind:"SetPermissionMode" make
117
+
|> Jsont.Object.mem "mode" Permissions.Mode.jsont ~enc:(fun (r : set_permission_mode_r) -> r.mode)
118
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : set_permission_mode_r) -> r.unknown)
119
+
|> Jsont.Object.finish)
120
+
121
+
let hook_callback_jsont : hook_callback_r Jsont.t =
122
+
let make callback_id input tool_use_id unknown =
123
+
{ callback_id; input; tool_use_id; unknown }
124
+
in
125
+
(Jsont.Object.map ~kind:"HookCallback" make
126
+
|> Jsont.Object.mem "callbackId" Jsont.string ~enc:(fun (r : hook_callback_r) -> r.callback_id)
127
+
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : hook_callback_r) -> r.input)
128
+
|> Jsont.Object.opt_mem "toolUseId" Jsont.string ~enc:(fun (r : hook_callback_r) ->
129
+
r.tool_use_id)
130
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : hook_callback_r) -> r.unknown)
131
+
|> Jsont.Object.finish)
132
+
133
+
let mcp_message_jsont : mcp_message_r Jsont.t =
134
+
let make server_name message unknown = { server_name; message; unknown } in
135
+
(Jsont.Object.map ~kind:"McpMessage" make
136
+
|> Jsont.Object.mem "serverName" Jsont.string ~enc:(fun (r : mcp_message_r) -> r.server_name)
137
+
|> Jsont.Object.mem "message" Jsont.json ~enc:(fun (r : mcp_message_r) -> r.message)
138
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : mcp_message_r) -> r.unknown)
139
+
|> Jsont.Object.finish)
140
+
141
+
let set_model_jsont : set_model_r Jsont.t =
142
+
let make model unknown = { model; unknown } in
143
+
(Jsont.Object.map ~kind:"SetModel" make
144
+
|> Jsont.Object.mem "model" Jsont.string ~enc:(fun (r : set_model_r) -> r.model)
145
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : set_model_r) -> r.unknown)
146
+
|> Jsont.Object.finish)
147
+
148
+
let get_server_info_jsont : unit Jsont.t =
149
+
(Jsont.Object.map ~kind:"GetServerInfo" (fun _unknown -> ())
150
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun () -> Unknown.empty)
151
+
|> Jsont.Object.finish)
152
+
153
+
(* Main variant codec using subtype discriminator *)
154
+
let jsont : t Jsont.t =
155
+
let case_interrupt =
156
+
Jsont.Object.Case.map "interrupt" interrupt_jsont ~dec:(fun () ->
157
+
Interrupt)
158
+
in
159
+
let case_permission =
160
+
Jsont.Object.Case.map "canUseTool" permission_jsont ~dec:(fun v ->
161
+
Permission v)
162
+
in
163
+
let case_initialize =
164
+
Jsont.Object.Case.map "initialize" initialize_jsont ~dec:(fun v ->
165
+
Initialize v)
166
+
in
167
+
let case_set_permission_mode =
168
+
Jsont.Object.Case.map "setPermissionMode" set_permission_mode_jsont
169
+
~dec:(fun v -> Set_permission_mode v)
170
+
in
171
+
let case_hook_callback =
172
+
Jsont.Object.Case.map "hookCallback" hook_callback_jsont ~dec:(fun v ->
173
+
Hook_callback v)
174
+
in
175
+
let case_mcp_message =
176
+
Jsont.Object.Case.map "mcpMessage" mcp_message_jsont ~dec:(fun v ->
177
+
Mcp_message v)
178
+
in
179
+
let case_set_model =
180
+
Jsont.Object.Case.map "setModel" set_model_jsont ~dec:(fun v ->
181
+
Set_model v)
182
+
in
183
+
let case_get_server_info =
184
+
Jsont.Object.Case.map "getServerInfo" get_server_info_jsont
185
+
~dec:(fun () -> Get_server_info)
186
+
in
187
+
188
+
let enc_case = function
189
+
| Interrupt -> Jsont.Object.Case.value case_interrupt ()
190
+
| Permission v -> Jsont.Object.Case.value case_permission v
191
+
| Initialize v -> Jsont.Object.Case.value case_initialize v
192
+
| Set_permission_mode v ->
193
+
Jsont.Object.Case.value case_set_permission_mode v
194
+
| Hook_callback v -> Jsont.Object.Case.value case_hook_callback v
195
+
| Mcp_message v -> Jsont.Object.Case.value case_mcp_message v
196
+
| Set_model v -> Jsont.Object.Case.value case_set_model v
197
+
| Get_server_info -> Jsont.Object.Case.value case_get_server_info ()
198
+
in
199
+
200
+
let cases =
201
+
Jsont.Object.Case.
202
+
[
203
+
make case_interrupt;
204
+
make case_permission;
205
+
make case_initialize;
206
+
make case_set_permission_mode;
207
+
make case_hook_callback;
208
+
make case_mcp_message;
209
+
make case_set_model;
210
+
make case_get_server_info;
211
+
]
212
+
in
213
+
214
+
Jsont.Object.map ~kind:"Request" Fun.id
215
+
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
216
+
~tag_to_string:Fun.id ~tag_compare:String.compare
217
+
|> Jsont.Object.finish
218
+
end
219
+
220
+
module Response = struct
221
+
(* Individual record types for each response variant *)
222
+
type success_r = {
223
+
request_id : string;
224
+
response : Jsont.json option;
225
+
unknown : Unknown.t;
226
+
}
227
+
228
+
type error_r = {
229
+
request_id : string;
230
+
error : string;
231
+
unknown : Unknown.t;
232
+
}
233
+
234
+
type t = Success of success_r | Error of error_r
235
+
236
+
let success ~request_id ?response () =
237
+
Success { request_id; response; unknown = Unknown.empty }
238
+
239
+
let error ~request_id ~error () =
240
+
Error { request_id; error; unknown = Unknown.empty }
241
+
242
+
(* Individual record codecs *)
243
+
let success_jsont : success_r Jsont.t =
244
+
let make request_id response unknown = { request_id; response; unknown } in
245
+
(Jsont.Object.map ~kind:"Success" make
246
+
|> Jsont.Object.mem "requestId" Jsont.string ~enc:(fun (r : success_r) -> r.request_id)
247
+
|> Jsont.Object.opt_mem "response" Jsont.json ~enc:(fun (r : success_r) -> r.response)
248
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : success_r) -> r.unknown)
249
+
|> Jsont.Object.finish)
250
+
251
+
let error_jsont : error_r Jsont.t =
252
+
let make request_id error unknown = { request_id; error; unknown } in
253
+
(Jsont.Object.map ~kind:"Error" make
254
+
|> Jsont.Object.mem "requestId" Jsont.string ~enc:(fun (r : error_r) -> r.request_id)
255
+
|> Jsont.Object.mem "error" Jsont.string ~enc:(fun (r : error_r) -> r.error)
256
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : error_r) -> r.unknown)
257
+
|> Jsont.Object.finish)
258
+
259
+
(* Main variant codec using subtype discriminator *)
260
+
let jsont : t Jsont.t =
261
+
let case_success =
262
+
Jsont.Object.Case.map "success" success_jsont ~dec:(fun v -> Success v)
263
+
in
264
+
let case_error =
265
+
Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
266
+
in
267
+
268
+
let enc_case = function
269
+
| Success v -> Jsont.Object.Case.value case_success v
270
+
| Error v -> Jsont.Object.Case.value case_error v
271
+
in
272
+
273
+
let cases = Jsont.Object.Case.[ make case_success; make case_error ] in
274
+
275
+
Jsont.Object.map ~kind:"Response" Fun.id
276
+
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
277
+
~tag_to_string:Fun.id ~tag_compare:String.compare
278
+
|> Jsont.Object.finish
279
+
end
280
+
281
+
type request_envelope = {
282
+
request_id : string;
283
+
request : Request.t;
284
+
unknown : Unknown.t;
285
+
}
286
+
287
+
type response_envelope = { response : Response.t; unknown : Unknown.t }
288
+
289
+
let create_request ~request_id ~request () =
290
+
{ request_id; request; unknown = Unknown.empty }
291
+
292
+
let create_response ~response () = { response; unknown = Unknown.empty }
293
+
294
+
(* Envelope codecs *)
295
+
let request_envelope_jsont : request_envelope Jsont.t =
296
+
let make request_id request unknown = { request_id; request; unknown } in
297
+
(Jsont.Object.map ~kind:"RequestEnvelope" make
298
+
|> Jsont.Object.mem "requestId" Jsont.string ~enc:(fun (r : request_envelope) -> r.request_id)
299
+
|> Jsont.Object.mem "request" Request.jsont ~enc:(fun (r : request_envelope) -> r.request)
300
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : request_envelope) -> r.unknown)
301
+
|> Jsont.Object.finish)
302
+
303
+
let response_envelope_jsont : response_envelope Jsont.t =
304
+
let make response unknown = { response; unknown } in
305
+
(Jsont.Object.map ~kind:"ResponseEnvelope" make
306
+
|> Jsont.Object.mem "response" Response.jsont ~enc:(fun (r : response_envelope) -> r.response)
307
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : response_envelope) -> r.unknown)
308
+
|> Jsont.Object.finish)
309
+
310
+
(** Server information *)
311
+
module Server_info = struct
312
+
type t = {
313
+
version : string;
314
+
capabilities : string list;
315
+
commands : string list;
316
+
output_styles : string list;
317
+
unknown : Unknown.t;
318
+
}
319
+
320
+
let create ~version ~capabilities ~commands ~output_styles () =
321
+
{ version; capabilities; commands; output_styles; unknown = Unknown.empty }
322
+
323
+
let version t = t.version
324
+
let capabilities t = t.capabilities
325
+
let commands t = t.commands
326
+
let output_styles t = t.output_styles
327
+
let unknown t = t.unknown
328
+
329
+
let jsont : t Jsont.t =
330
+
let make version capabilities commands output_styles unknown =
331
+
{ version; capabilities; commands; output_styles; unknown }
332
+
in
333
+
Jsont.Object.map ~kind:"ServerInfo" make
334
+
|> Jsont.Object.mem "version" Jsont.string ~enc:(fun r -> r.version)
335
+
|> Jsont.Object.mem "capabilities" (Jsont.list Jsont.string)
336
+
~enc:(fun r -> r.capabilities)
337
+
~dec_absent:[]
338
+
|> Jsont.Object.mem "commands" (Jsont.list Jsont.string)
339
+
~enc:(fun r -> r.commands)
340
+
~dec_absent:[]
341
+
|> Jsont.Object.mem "outputStyles" (Jsont.list Jsont.string)
342
+
~enc:(fun r -> r.output_styles)
343
+
~dec_absent:[]
344
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun r -> r.unknown)
345
+
|> Jsont.Object.finish
346
+
end
+197
proto/control.mli
+197
proto/control.mli
···
1
+
(** Control protocol wire format for SDK communication.
2
+
3
+
This module defines the wire format for the SDK control protocol used for
4
+
bidirectional communication between the SDK and the Claude CLI. It handles
5
+
JSON serialization and deserialization of control messages.
6
+
7
+
The control protocol enables:
8
+
- Permission requests for tool usage authorization
9
+
- Hook callbacks for intercepting and modifying tool execution
10
+
- Dynamic control for changing settings mid-conversation
11
+
- Server introspection for querying capabilities *)
12
+
13
+
(** {1 Request Types} *)
14
+
15
+
module Request : sig
16
+
(** SDK control request types. *)
17
+
18
+
type permission_r = private {
19
+
tool_name : string;
20
+
input : Jsont.json;
21
+
permission_suggestions : Permissions.Update.t list option;
22
+
blocked_path : string option;
23
+
unknown : Unknown.t;
24
+
}
25
+
26
+
type initialize_r = private {
27
+
hooks : (string * Jsont.json) list option;
28
+
unknown : Unknown.t;
29
+
}
30
+
31
+
type set_permission_mode_r = private {
32
+
mode : Permissions.Mode.t;
33
+
unknown : Unknown.t;
34
+
}
35
+
36
+
type hook_callback_r = private {
37
+
callback_id : string;
38
+
input : Jsont.json;
39
+
tool_use_id : string option;
40
+
unknown : Unknown.t;
41
+
}
42
+
43
+
type mcp_message_r = private {
44
+
server_name : string;
45
+
message : Jsont.json;
46
+
unknown : Unknown.t;
47
+
}
48
+
49
+
type set_model_r = private { model : string; unknown : Unknown.t }
50
+
51
+
type t =
52
+
| Interrupt
53
+
| Permission of permission_r
54
+
| Initialize of initialize_r
55
+
| Set_permission_mode of set_permission_mode_r
56
+
| Hook_callback of hook_callback_r
57
+
| Mcp_message of mcp_message_r
58
+
| Set_model of set_model_r
59
+
| Get_server_info
60
+
(** The type of SDK control requests. Wire format uses "subtype" field:
61
+
"interrupt", "canUseTool", "initialize", "setPermissionMode",
62
+
"hookCallback", "mcpMessage", "setModel", "getServerInfo". *)
63
+
64
+
val jsont : t Jsont.t
65
+
(** [jsont] is the Jsont codec for requests. *)
66
+
67
+
val interrupt : unit -> t
68
+
(** [interrupt ()] creates an interrupt request. *)
69
+
70
+
val permission :
71
+
tool_name:string ->
72
+
input:Jsont.json ->
73
+
?permission_suggestions:Permissions.Update.t list ->
74
+
?blocked_path:string ->
75
+
unit ->
76
+
t
77
+
(** [permission ~tool_name ~input ?permission_suggestions ?blocked_path ()]
78
+
creates a permission request. *)
79
+
80
+
val initialize : ?hooks:(string * Jsont.json) list -> unit -> t
81
+
(** [initialize ?hooks ()] creates an initialize request. *)
82
+
83
+
val set_permission_mode : mode:Permissions.Mode.t -> unit -> t
84
+
(** [set_permission_mode ~mode ()] creates a permission mode change request.
85
+
*)
86
+
87
+
val hook_callback :
88
+
callback_id:string ->
89
+
input:Jsont.json ->
90
+
?tool_use_id:string ->
91
+
unit ->
92
+
t
93
+
(** [hook_callback ~callback_id ~input ?tool_use_id ()] creates a hook
94
+
callback request. *)
95
+
96
+
val mcp_message : server_name:string -> message:Jsont.json -> unit -> t
97
+
(** [mcp_message ~server_name ~message ()] creates an MCP message request. *)
98
+
99
+
val set_model : model:string -> unit -> t
100
+
(** [set_model ~model ()] creates a model change request. *)
101
+
102
+
val get_server_info : unit -> t
103
+
(** [get_server_info ()] creates a server info request. *)
104
+
end
105
+
106
+
(** {1 Response Types} *)
107
+
108
+
module Response : sig
109
+
(** SDK control response types. *)
110
+
111
+
type success_r = private {
112
+
request_id : string;
113
+
response : Jsont.json option;
114
+
unknown : Unknown.t;
115
+
}
116
+
117
+
type error_r = private {
118
+
request_id : string;
119
+
error : string;
120
+
unknown : Unknown.t;
121
+
}
122
+
123
+
type t = Success of success_r | Error of error_r
124
+
(** The type of SDK control responses. Wire format uses "subtype" field:
125
+
"success", "error". *)
126
+
127
+
val jsont : t Jsont.t
128
+
(** [jsont] is the Jsont codec for responses. *)
129
+
130
+
val success : request_id:string -> ?response:Jsont.json -> unit -> t
131
+
(** [success ~request_id ?response ()] creates a success response. *)
132
+
133
+
val error : request_id:string -> error:string -> unit -> t
134
+
(** [error ~request_id ~error ()] creates an error response. *)
135
+
end
136
+
137
+
(** {1 Control Envelopes} *)
138
+
139
+
type request_envelope = {
140
+
request_id : string;
141
+
request : Request.t;
142
+
unknown : Unknown.t;
143
+
}
144
+
(** Control request envelope. Wire format has "type": "control_request". *)
145
+
146
+
type response_envelope = { response : Response.t; unknown : Unknown.t }
147
+
(** Control response envelope. Wire format has "type": "control_response". *)
148
+
149
+
val request_envelope_jsont : request_envelope Jsont.t
150
+
(** [request_envelope_jsont] is the Jsont codec for request envelopes. *)
151
+
152
+
val response_envelope_jsont : response_envelope Jsont.t
153
+
(** [response_envelope_jsont] is the Jsont codec for response envelopes. *)
154
+
155
+
val create_request : request_id:string -> request:Request.t -> unit -> request_envelope
156
+
(** [create_request ~request_id ~request ()] creates a control request envelope.
157
+
*)
158
+
159
+
val create_response : response:Response.t -> unit -> response_envelope
160
+
(** [create_response ~response ()] creates a control response envelope. *)
161
+
162
+
(** {1 Server Information} *)
163
+
164
+
module Server_info : sig
165
+
(** Server information and capabilities. *)
166
+
167
+
type t
168
+
(** Server metadata and capabilities. *)
169
+
170
+
val jsont : t Jsont.t
171
+
(** [jsont] is the Jsont codec for server info. *)
172
+
173
+
val create :
174
+
version:string ->
175
+
capabilities:string list ->
176
+
commands:string list ->
177
+
output_styles:string list ->
178
+
unit ->
179
+
t
180
+
(** [create ~version ~capabilities ~commands ~output_styles ()] creates
181
+
server info. *)
182
+
183
+
val version : t -> string
184
+
(** [version t] returns the server version. *)
185
+
186
+
val capabilities : t -> string list
187
+
(** [capabilities t] returns the server capabilities. *)
188
+
189
+
val commands : t -> string list
190
+
(** [commands t] returns available commands. *)
191
+
192
+
val output_styles : t -> string list
193
+
(** [output_styles t] returns available output styles. *)
194
+
195
+
val unknown : t -> Unknown.t
196
+
(** [unknown t] returns the unknown fields. *)
197
+
end
+4
proto/dune
+4
proto/dune
+474
proto/hooks.ml
+474
proto/hooks.ml
···
1
+
(** Claude Code Hooks System - Wire Format
2
+
3
+
This module defines the wire format for hook configuration. *)
4
+
5
+
(** Hook events that can be intercepted *)
6
+
type event =
7
+
| Pre_tool_use
8
+
| Post_tool_use
9
+
| User_prompt_submit
10
+
| Stop
11
+
| Subagent_stop
12
+
| Pre_compact
13
+
14
+
let event_to_string = function
15
+
| Pre_tool_use -> "PreToolUse"
16
+
| Post_tool_use -> "PostToolUse"
17
+
| User_prompt_submit -> "UserPromptSubmit"
18
+
| Stop -> "Stop"
19
+
| Subagent_stop -> "SubagentStop"
20
+
| Pre_compact -> "PreCompact"
21
+
22
+
let event_of_string = function
23
+
| "PreToolUse" -> Pre_tool_use
24
+
| "PostToolUse" -> Post_tool_use
25
+
| "UserPromptSubmit" -> User_prompt_submit
26
+
| "Stop" -> Stop
27
+
| "SubagentStop" -> Subagent_stop
28
+
| "PreCompact" -> Pre_compact
29
+
| s -> raise (Invalid_argument (Printf.sprintf "Unknown hook event: %s" s))
30
+
31
+
let event_jsont : event Jsont.t =
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
+
]
41
+
42
+
(** Context provided to hook callbacks *)
43
+
module Context = struct
44
+
type t = { signal : unit option; unknown : Unknown.t }
45
+
46
+
let create ?signal () =
47
+
let signal = Option.map (fun () -> ()) signal in
48
+
{ signal; unknown = Unknown.empty }
49
+
50
+
let signal t = t.signal
51
+
let unknown t = t.unknown
52
+
53
+
let jsont : t Jsont.t =
54
+
let make unknown = { signal = None; unknown } in
55
+
Jsont.Object.map ~kind:"Context" make
56
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
57
+
|> Jsont.Object.finish
58
+
end
59
+
60
+
(** Hook decision control *)
61
+
type decision = Continue | Block
62
+
63
+
let decision_jsont : decision Jsont.t =
64
+
Jsont.enum [ ("continue", Continue); ("block", Block) ]
65
+
66
+
(** Generic hook result *)
67
+
type result = {
68
+
decision : decision option;
69
+
system_message : string option;
70
+
hook_specific_output : Jsont.json option;
71
+
unknown : Unknown.t;
72
+
}
73
+
74
+
let result_jsont : result Jsont.t =
75
+
let make decision system_message hook_specific_output unknown =
76
+
{ decision; system_message; hook_specific_output; unknown }
77
+
in
78
+
Jsont.Object.map ~kind:"Result" make
79
+
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun r -> r.decision)
80
+
|> Jsont.Object.opt_mem "systemMessage" Jsont.string ~enc:(fun r ->
81
+
r.system_message)
82
+
|> Jsont.Object.opt_mem "hookSpecificOutput" Jsont.json ~enc:(fun r ->
83
+
r.hook_specific_output)
84
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun r -> r.unknown)
85
+
|> Jsont.Object.finish
86
+
87
+
(** {1 PreToolUse Hook} *)
88
+
module PreToolUse = struct
89
+
module Input = struct
90
+
type t = {
91
+
session_id : string;
92
+
transcript_path : string;
93
+
tool_name : string;
94
+
tool_input : Jsont.json;
95
+
unknown : Unknown.t;
96
+
}
97
+
98
+
let session_id t = t.session_id
99
+
let transcript_path t = t.transcript_path
100
+
let tool_name t = t.tool_name
101
+
let tool_input t = t.tool_input
102
+
let unknown t = t.unknown
103
+
104
+
let jsont : t Jsont.t =
105
+
let make session_id transcript_path tool_name tool_input unknown =
106
+
{ session_id; transcript_path; tool_name; tool_input; unknown }
107
+
in
108
+
Jsont.Object.map ~kind:"PreToolUseInput" make
109
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
110
+
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
111
+
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:tool_name
112
+
|> Jsont.Object.mem "tool_input" Jsont.json ~enc:tool_input
113
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
114
+
|> Jsont.Object.finish
115
+
end
116
+
117
+
type permission_decision = [ `Allow | `Deny | `Ask ]
118
+
119
+
let permission_decision_jsont : permission_decision Jsont.t =
120
+
Jsont.enum [ ("allow", `Allow); ("deny", `Deny); ("ask", `Ask) ]
121
+
122
+
module Output = struct
123
+
type t = {
124
+
permission_decision : permission_decision option;
125
+
permission_decision_reason : string option;
126
+
updated_input : Jsont.json option;
127
+
unknown : Unknown.t;
128
+
}
129
+
130
+
let jsont : t Jsont.t =
131
+
let make _hook_event_name permission_decision permission_decision_reason
132
+
updated_input unknown =
133
+
{
134
+
permission_decision;
135
+
permission_decision_reason;
136
+
updated_input;
137
+
unknown;
138
+
}
139
+
in
140
+
Jsont.Object.map ~kind:"PreToolUseOutput" make
141
+
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ ->
142
+
"PreToolUse")
143
+
|> Jsont.Object.opt_mem "permissionDecision" permission_decision_jsont
144
+
~enc:(fun o -> o.permission_decision)
145
+
|> Jsont.Object.opt_mem "permissionDecisionReason" Jsont.string
146
+
~enc:(fun o -> o.permission_decision_reason)
147
+
|> Jsont.Object.opt_mem "updatedInput" Jsont.json ~enc:(fun o ->
148
+
o.updated_input)
149
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun o -> o.unknown)
150
+
|> Jsont.Object.finish
151
+
152
+
let allow ?reason ?updated_input () =
153
+
{
154
+
permission_decision = Some `Allow;
155
+
permission_decision_reason = reason;
156
+
updated_input;
157
+
unknown = Unknown.empty;
158
+
}
159
+
160
+
let deny ?reason () =
161
+
{
162
+
permission_decision = Some `Deny;
163
+
permission_decision_reason = reason;
164
+
updated_input = None;
165
+
unknown = Unknown.empty;
166
+
}
167
+
168
+
let ask ?reason () =
169
+
{
170
+
permission_decision = Some `Ask;
171
+
permission_decision_reason = reason;
172
+
updated_input = None;
173
+
unknown = Unknown.empty;
174
+
}
175
+
176
+
let continue () =
177
+
{
178
+
permission_decision = None;
179
+
permission_decision_reason = None;
180
+
updated_input = None;
181
+
unknown = Unknown.empty;
182
+
}
183
+
end
184
+
end
185
+
186
+
(** {1 PostToolUse Hook} *)
187
+
module PostToolUse = struct
188
+
module Input = struct
189
+
type t = {
190
+
session_id : string;
191
+
transcript_path : string;
192
+
tool_name : string;
193
+
tool_input : Jsont.json;
194
+
tool_response : Jsont.json;
195
+
unknown : Unknown.t;
196
+
}
197
+
198
+
let session_id t = t.session_id
199
+
let transcript_path t = t.transcript_path
200
+
let tool_name t = t.tool_name
201
+
let tool_input t = t.tool_input
202
+
let tool_response t = t.tool_response
203
+
let unknown t = t.unknown
204
+
205
+
let jsont : t Jsont.t =
206
+
let make session_id transcript_path tool_name tool_input tool_response
207
+
unknown =
208
+
{
209
+
session_id;
210
+
transcript_path;
211
+
tool_name;
212
+
tool_input;
213
+
tool_response;
214
+
unknown;
215
+
}
216
+
in
217
+
Jsont.Object.map ~kind:"PostToolUseInput" make
218
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
219
+
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
220
+
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:tool_name
221
+
|> Jsont.Object.mem "tool_input" Jsont.json ~enc:tool_input
222
+
|> Jsont.Object.mem "tool_response" Jsont.json ~enc:tool_response
223
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
224
+
|> Jsont.Object.finish
225
+
end
226
+
227
+
module Output = struct
228
+
type t = {
229
+
decision : decision option;
230
+
reason : string option;
231
+
additional_context : string option;
232
+
unknown : Unknown.t;
233
+
}
234
+
235
+
let jsont : t Jsont.t =
236
+
let make _hook_event_name decision reason additional_context unknown =
237
+
{ decision; reason; additional_context; unknown }
238
+
in
239
+
Jsont.Object.map ~kind:"PostToolUseOutput" make
240
+
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ ->
241
+
"PostToolUse")
242
+
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o -> o.decision)
243
+
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
244
+
|> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o ->
245
+
o.additional_context)
246
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun o -> o.unknown)
247
+
|> Jsont.Object.finish
248
+
249
+
let continue ?additional_context () =
250
+
{
251
+
decision = None;
252
+
reason = None;
253
+
additional_context;
254
+
unknown = Unknown.empty;
255
+
}
256
+
257
+
let block ?reason ?additional_context () =
258
+
{
259
+
decision = Some Block;
260
+
reason;
261
+
additional_context;
262
+
unknown = Unknown.empty;
263
+
}
264
+
end
265
+
end
266
+
267
+
(** {1 UserPromptSubmit Hook} *)
268
+
module UserPromptSubmit = struct
269
+
module Input = struct
270
+
type t = {
271
+
session_id : string;
272
+
transcript_path : string;
273
+
prompt : string;
274
+
unknown : Unknown.t;
275
+
}
276
+
277
+
let session_id t = t.session_id
278
+
let transcript_path t = t.transcript_path
279
+
let prompt t = t.prompt
280
+
let unknown t = t.unknown
281
+
282
+
let jsont : t Jsont.t =
283
+
let make session_id transcript_path prompt unknown =
284
+
{ session_id; transcript_path; prompt; unknown }
285
+
in
286
+
Jsont.Object.map ~kind:"UserPromptSubmitInput" make
287
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
288
+
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
289
+
|> Jsont.Object.mem "prompt" Jsont.string ~enc:prompt
290
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
291
+
|> Jsont.Object.finish
292
+
end
293
+
294
+
module Output = struct
295
+
type t = {
296
+
decision : decision option;
297
+
reason : string option;
298
+
additional_context : string option;
299
+
unknown : Unknown.t;
300
+
}
301
+
302
+
let jsont : t Jsont.t =
303
+
let make _hook_event_name decision reason additional_context unknown =
304
+
{ decision; reason; additional_context; unknown }
305
+
in
306
+
Jsont.Object.map ~kind:"UserPromptSubmitOutput" make
307
+
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ ->
308
+
"UserPromptSubmit")
309
+
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o -> o.decision)
310
+
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
311
+
|> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o ->
312
+
o.additional_context)
313
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun o -> o.unknown)
314
+
|> Jsont.Object.finish
315
+
316
+
let continue ?additional_context () =
317
+
{
318
+
decision = None;
319
+
reason = None;
320
+
additional_context;
321
+
unknown = Unknown.empty;
322
+
}
323
+
324
+
let block ?reason () =
325
+
{
326
+
decision = Some Block;
327
+
reason;
328
+
additional_context = None;
329
+
unknown = Unknown.empty;
330
+
}
331
+
end
332
+
end
333
+
334
+
(** {1 Stop Hook} *)
335
+
module Stop = struct
336
+
module Input = struct
337
+
type t = {
338
+
session_id : string;
339
+
transcript_path : string;
340
+
stop_hook_active : bool;
341
+
unknown : Unknown.t;
342
+
}
343
+
344
+
let session_id t = t.session_id
345
+
let transcript_path t = t.transcript_path
346
+
let stop_hook_active t = t.stop_hook_active
347
+
let unknown t = t.unknown
348
+
349
+
let jsont : t Jsont.t =
350
+
let make session_id transcript_path stop_hook_active unknown =
351
+
{ session_id; transcript_path; stop_hook_active; unknown }
352
+
in
353
+
Jsont.Object.map ~kind:"StopInput" make
354
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
355
+
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
356
+
|> Jsont.Object.mem "stop_hook_active" Jsont.bool ~enc:stop_hook_active
357
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
358
+
|> Jsont.Object.finish
359
+
end
360
+
361
+
module Output = struct
362
+
type t = {
363
+
decision : decision option;
364
+
reason : string option;
365
+
unknown : Unknown.t;
366
+
}
367
+
368
+
let jsont : t Jsont.t =
369
+
let make _hook_event_name decision reason unknown =
370
+
{ decision; reason; unknown }
371
+
in
372
+
Jsont.Object.map ~kind:"StopOutput" make
373
+
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ -> "Stop")
374
+
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o -> o.decision)
375
+
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
376
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun o -> o.unknown)
377
+
|> Jsont.Object.finish
378
+
379
+
let continue () =
380
+
{ decision = None; reason = None; unknown = Unknown.empty }
381
+
382
+
let block ?reason () =
383
+
{ decision = Some Block; reason; unknown = Unknown.empty }
384
+
end
385
+
end
386
+
387
+
(** {1 SubagentStop Hook} - Same structure as Stop *)
388
+
module SubagentStop = struct
389
+
module Input = struct
390
+
type t = Stop.Input.t
391
+
392
+
let jsont = Stop.Input.jsont
393
+
let session_id = Stop.Input.session_id
394
+
let transcript_path = Stop.Input.transcript_path
395
+
let stop_hook_active = Stop.Input.stop_hook_active
396
+
let unknown = Stop.Input.unknown
397
+
end
398
+
399
+
module Output = struct
400
+
type t = Stop.Output.t
401
+
402
+
let jsont : t Jsont.t =
403
+
let make _hook_event_name decision reason unknown : t =
404
+
{ Stop.Output.decision; reason; unknown }
405
+
in
406
+
Jsont.Object.map ~kind:"SubagentStopOutput" make
407
+
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ ->
408
+
"SubagentStop")
409
+
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun (o : t) ->
410
+
o.Stop.Output.decision)
411
+
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun (o : t) ->
412
+
o.Stop.Output.reason)
413
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (o : t) ->
414
+
o.Stop.Output.unknown)
415
+
|> Jsont.Object.finish
416
+
417
+
let continue = Stop.Output.continue
418
+
let block = Stop.Output.block
419
+
end
420
+
end
421
+
422
+
(** {1 PreCompact Hook} *)
423
+
module PreCompact = struct
424
+
module Input = struct
425
+
type t = {
426
+
session_id : string;
427
+
transcript_path : string;
428
+
unknown : Unknown.t;
429
+
}
430
+
431
+
let session_id t = t.session_id
432
+
let transcript_path t = t.transcript_path
433
+
let unknown t = t.unknown
434
+
435
+
let jsont : t Jsont.t =
436
+
let make session_id transcript_path unknown =
437
+
{ session_id; transcript_path; unknown }
438
+
in
439
+
Jsont.Object.map ~kind:"PreCompactInput" make
440
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
441
+
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
442
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
443
+
|> Jsont.Object.finish
444
+
end
445
+
446
+
module Output = struct
447
+
type t = unit
448
+
449
+
let jsont : t Jsont.t =
450
+
Jsont.Object.map ~kind:"PreCompactOutput" (fun _hook_event_name -> ())
451
+
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun () ->
452
+
"PreCompact")
453
+
|> Jsont.Object.finish
454
+
455
+
let continue () = ()
456
+
end
457
+
end
458
+
459
+
(** {1 Result Builders} *)
460
+
let continue ?system_message ?hook_specific_output () =
461
+
{
462
+
decision = None;
463
+
system_message;
464
+
hook_specific_output;
465
+
unknown = Unknown.empty;
466
+
}
467
+
468
+
let block ?system_message ?hook_specific_output () =
469
+
{
470
+
decision = Some Block;
471
+
system_message;
472
+
hook_specific_output;
473
+
unknown = Unknown.empty;
474
+
}
+359
proto/hooks.mli
+359
proto/hooks.mli
···
1
+
(** Claude Code Hooks System - Wire Format
2
+
3
+
This module defines the wire format for hook configuration. Hooks allow you
4
+
to intercept and control events in Claude Code sessions, such as tool usage,
5
+
prompt submission, and session stops.
6
+
7
+
{1 Overview}
8
+
9
+
Hooks are organized by event type, with each event having:
10
+
- A typed input structure (accessible via submodules)
11
+
- A typed output structure for responses
12
+
- Helper functions for common responses
13
+
14
+
This is the wire format module - it does not include the callback system or
15
+
Eio dependencies. For the full hooks system with callbacks, see the
16
+
[Hooks] module in the [lib] directory. *)
17
+
18
+
(** {1 Hook Events} *)
19
+
20
+
type event =
21
+
| Pre_tool_use (** Fires before a tool is executed *)
22
+
| Post_tool_use (** Fires after a tool completes *)
23
+
| User_prompt_submit (** Fires when user submits a prompt *)
24
+
| Stop (** Fires when conversation stops *)
25
+
| Subagent_stop (** Fires when a subagent stops *)
26
+
| Pre_compact (** Fires before message compaction *)
27
+
(** Hook event types *)
28
+
29
+
val event_to_string : event -> string
30
+
(** [event_to_string event] converts an event to its wire format string.
31
+
Wire format: "PreToolUse", "PostToolUse", "UserPromptSubmit", "Stop",
32
+
"SubagentStop", "PreCompact" *)
33
+
34
+
val event_of_string : string -> event
35
+
(** [event_of_string s] parses an event from its wire format string.
36
+
@raise Invalid_argument if the string is not a valid event. *)
37
+
38
+
val event_jsont : event Jsont.t
39
+
(** [event_jsont] is the Jsont codec for hook events. *)
40
+
41
+
(** {1 Context} *)
42
+
43
+
module Context : sig
44
+
(** Context provided to hook callbacks. *)
45
+
46
+
type t
47
+
(** The type of hook context. *)
48
+
49
+
val jsont : t Jsont.t
50
+
(** [jsont] is the Jsont codec for hook context. Preserves unknown fields. *)
51
+
52
+
val create : ?signal:unit -> unit -> t
53
+
(** [create ?signal ()] creates a new context.
54
+
@param signal Optional abort signal support (future use) *)
55
+
56
+
val signal : t -> unit option
57
+
(** [signal t] returns the optional abort signal. *)
58
+
59
+
val unknown : t -> Unknown.t
60
+
(** [unknown t] returns the unknown fields. *)
61
+
end
62
+
63
+
(** {1 Decisions} *)
64
+
65
+
type decision =
66
+
| Continue (** Allow the action to proceed *)
67
+
| Block (** Block the action *)
68
+
(** Hook decision control *)
69
+
70
+
val decision_jsont : decision Jsont.t
71
+
(** [decision_jsont] is the Jsont codec for hook decisions.
72
+
Wire format: "continue", "block" *)
73
+
74
+
(** {1 Typed Hook Modules} *)
75
+
76
+
(** PreToolUse hook - fires before tool execution *)
77
+
module PreToolUse : sig
78
+
(** {2 Input} *)
79
+
80
+
module Input : sig
81
+
type t
82
+
(** Typed input for PreToolUse hooks *)
83
+
84
+
val jsont : t Jsont.t
85
+
(** [jsont] is the Jsont codec for PreToolUse input. *)
86
+
87
+
val session_id : t -> string
88
+
(** [session_id t] returns the session ID. *)
89
+
90
+
val transcript_path : t -> string
91
+
(** [transcript_path t] returns the transcript file path. *)
92
+
93
+
val tool_name : t -> string
94
+
(** [tool_name t] returns the tool name being invoked. *)
95
+
96
+
val tool_input : t -> Jsont.json
97
+
(** [tool_input t] returns the tool's input as raw JSON. *)
98
+
99
+
val unknown : t -> Unknown.t
100
+
(** [unknown t] returns the unknown fields. *)
101
+
end
102
+
103
+
(** {2 Output} *)
104
+
105
+
type permission_decision = [ `Allow | `Deny | `Ask ]
106
+
(** Permission decision for tool usage.
107
+
Wire format: "allow", "deny", "ask" *)
108
+
109
+
val permission_decision_jsont : permission_decision Jsont.t
110
+
(** [permission_decision_jsont] is the Jsont codec for permission decisions. *)
111
+
112
+
module Output : sig
113
+
type t
114
+
(** Typed output for PreToolUse hooks *)
115
+
116
+
val jsont : t Jsont.t
117
+
(** [jsont] is the Jsont codec for PreToolUse output. *)
118
+
119
+
val allow :
120
+
?reason:string -> ?updated_input:Jsont.json -> unit -> t
121
+
(** [allow ?reason ?updated_input ()] creates an allow response.
122
+
@param reason Optional explanation for allowing
123
+
@param updated_input Optional modified tool input *)
124
+
125
+
val deny : ?reason:string -> unit -> t
126
+
(** [deny ?reason ()] creates a deny response.
127
+
@param reason Optional explanation for denying *)
128
+
129
+
val ask : ?reason:string -> unit -> t
130
+
(** [ask ?reason ()] creates an ask response to prompt the user.
131
+
@param reason Optional explanation for asking *)
132
+
133
+
val continue : unit -> t
134
+
(** [continue ()] creates a continue response with no decision. *)
135
+
end
136
+
end
137
+
138
+
(** PostToolUse hook - fires after tool execution *)
139
+
module PostToolUse : sig
140
+
(** {2 Input} *)
141
+
142
+
module Input : sig
143
+
type t
144
+
(** Typed input for PostToolUse hooks *)
145
+
146
+
val jsont : t Jsont.t
147
+
(** [jsont] is the Jsont codec for PostToolUse input. *)
148
+
149
+
val session_id : t -> string
150
+
(** [session_id t] returns the session ID. *)
151
+
152
+
val transcript_path : t -> string
153
+
(** [transcript_path t] returns the transcript file path. *)
154
+
155
+
val tool_name : t -> string
156
+
(** [tool_name t] returns the tool name that was invoked. *)
157
+
158
+
val tool_input : t -> Jsont.json
159
+
(** [tool_input t] returns the tool's input as raw JSON. *)
160
+
161
+
val tool_response : t -> Jsont.json
162
+
(** [tool_response t] returns the tool's response as raw JSON. *)
163
+
164
+
val unknown : t -> Unknown.t
165
+
(** [unknown t] returns the unknown fields. *)
166
+
end
167
+
168
+
(** {2 Output} *)
169
+
170
+
module Output : sig
171
+
type t
172
+
(** Typed output for PostToolUse hooks *)
173
+
174
+
val jsont : t Jsont.t
175
+
(** [jsont] is the Jsont codec for PostToolUse output. *)
176
+
177
+
val continue : ?additional_context:string -> unit -> t
178
+
(** [continue ?additional_context ()] creates a continue response.
179
+
@param additional_context Optional context to add to the transcript *)
180
+
181
+
val block : ?reason:string -> ?additional_context:string -> unit -> t
182
+
(** [block ?reason ?additional_context ()] creates a block response.
183
+
@param reason Optional explanation for blocking
184
+
@param additional_context Optional context to add to the transcript *)
185
+
end
186
+
end
187
+
188
+
(** UserPromptSubmit hook - fires when user submits a prompt *)
189
+
module UserPromptSubmit : sig
190
+
(** {2 Input} *)
191
+
192
+
module Input : sig
193
+
type t
194
+
(** Typed input for UserPromptSubmit hooks *)
195
+
196
+
val jsont : t Jsont.t
197
+
(** [jsont] is the Jsont codec for UserPromptSubmit input. *)
198
+
199
+
val session_id : t -> string
200
+
(** [session_id t] returns the session ID. *)
201
+
202
+
val transcript_path : t -> string
203
+
(** [transcript_path t] returns the transcript file path. *)
204
+
205
+
val prompt : t -> string
206
+
(** [prompt t] returns the user's prompt text. *)
207
+
208
+
val unknown : t -> Unknown.t
209
+
(** [unknown t] returns the unknown fields. *)
210
+
end
211
+
212
+
(** {2 Output} *)
213
+
214
+
module Output : sig
215
+
type t
216
+
(** Typed output for UserPromptSubmit hooks *)
217
+
218
+
val jsont : t Jsont.t
219
+
(** [jsont] is the Jsont codec for UserPromptSubmit output. *)
220
+
221
+
val continue : ?additional_context:string -> unit -> t
222
+
(** [continue ?additional_context ()] creates a continue response.
223
+
@param additional_context Optional context to add to the transcript *)
224
+
225
+
val block : ?reason:string -> unit -> t
226
+
(** [block ?reason ()] creates a block response.
227
+
@param reason Optional explanation for blocking *)
228
+
end
229
+
end
230
+
231
+
(** Stop hook - fires when conversation stops *)
232
+
module Stop : sig
233
+
(** {2 Input} *)
234
+
235
+
module Input : sig
236
+
type t
237
+
(** Typed input for Stop hooks *)
238
+
239
+
val jsont : t Jsont.t
240
+
(** [jsont] is the Jsont codec for Stop input. *)
241
+
242
+
val session_id : t -> string
243
+
(** [session_id t] returns the session ID. *)
244
+
245
+
val transcript_path : t -> string
246
+
(** [transcript_path t] returns the transcript file path. *)
247
+
248
+
val stop_hook_active : t -> bool
249
+
(** [stop_hook_active t] returns whether stop hooks are active. *)
250
+
251
+
val unknown : t -> Unknown.t
252
+
(** [unknown t] returns the unknown fields. *)
253
+
end
254
+
255
+
(** {2 Output} *)
256
+
257
+
module Output : sig
258
+
type t
259
+
(** Typed output for Stop hooks *)
260
+
261
+
val jsont : t Jsont.t
262
+
(** [jsont] is the Jsont codec for Stop output. *)
263
+
264
+
val continue : unit -> t
265
+
(** [continue ()] creates a continue response. *)
266
+
267
+
val block : ?reason:string -> unit -> t
268
+
(** [block ?reason ()] creates a block response.
269
+
@param reason Optional explanation for blocking *)
270
+
end
271
+
end
272
+
273
+
(** SubagentStop hook - fires when a subagent stops *)
274
+
module SubagentStop : sig
275
+
(** {2 Input} *)
276
+
277
+
module Input : sig
278
+
type t = Stop.Input.t
279
+
(** Same structure as Stop.Input *)
280
+
281
+
val jsont : t Jsont.t
282
+
val session_id : t -> string
283
+
val transcript_path : t -> string
284
+
val stop_hook_active : t -> bool
285
+
val unknown : t -> Unknown.t
286
+
end
287
+
288
+
(** {2 Output} *)
289
+
290
+
module Output : sig
291
+
type t = Stop.Output.t
292
+
(** Same structure as Stop.Output *)
293
+
294
+
val jsont : t Jsont.t
295
+
val continue : unit -> t
296
+
val block : ?reason:string -> unit -> t
297
+
end
298
+
end
299
+
300
+
(** PreCompact hook - fires before message compaction *)
301
+
module PreCompact : sig
302
+
(** {2 Input} *)
303
+
304
+
module Input : sig
305
+
type t
306
+
(** Typed input for PreCompact hooks *)
307
+
308
+
val jsont : t Jsont.t
309
+
(** [jsont] is the Jsont codec for PreCompact input. *)
310
+
311
+
val session_id : t -> string
312
+
(** [session_id t] returns the session ID. *)
313
+
314
+
val transcript_path : t -> string
315
+
(** [transcript_path t] returns the transcript file path. *)
316
+
317
+
val unknown : t -> Unknown.t
318
+
(** [unknown t] returns the unknown fields. *)
319
+
end
320
+
321
+
(** {2 Output} *)
322
+
323
+
module Output : sig
324
+
type t = unit
325
+
(** PreCompact has no specific output *)
326
+
327
+
val jsont : t Jsont.t
328
+
(** [jsont] is the Jsont codec for PreCompact output (unit codec). *)
329
+
330
+
val continue : unit -> t
331
+
(** [continue ()] returns unit. *)
332
+
end
333
+
end
334
+
335
+
(** {1 Generic Hook Result} *)
336
+
337
+
type result = {
338
+
decision : decision option;
339
+
system_message : string option;
340
+
hook_specific_output : Jsont.json option;
341
+
unknown : Unknown.t;
342
+
}
343
+
(** Generic result structure for hooks *)
344
+
345
+
val result_jsont : result Jsont.t
346
+
(** [result_jsont] is the Jsont codec for hook results. *)
347
+
348
+
val continue :
349
+
?system_message:string -> ?hook_specific_output:Jsont.json -> unit -> result
350
+
(** [continue ?system_message ?hook_specific_output ()] creates a continue
351
+
result.
352
+
@param system_message Optional message to add to system context
353
+
@param hook_specific_output Optional hook-specific output data *)
354
+
355
+
val block :
356
+
?system_message:string -> ?hook_specific_output:Jsont.json -> unit -> result
357
+
(** [block ?system_message ?hook_specific_output ()] creates a block result.
358
+
@param system_message Optional message to add to system context
359
+
@param hook_specific_output Optional hook-specific output data *)
+67
proto/incoming.ml
+67
proto/incoming.ml
···
1
+
(** Incoming messages from Claude CLI.
2
+
3
+
This uses the Control module's request_envelope_jsont and
4
+
response_envelope_jsont for control messages, and Message.jsont for
5
+
conversation messages. The top-level discriminator is the "type" field. *)
6
+
7
+
type t =
8
+
| Message of Message.t
9
+
| Control_response of Control.response_envelope
10
+
| Control_request of Control.request_envelope
11
+
12
+
let jsont : t Jsont.t =
13
+
(* Message types use "user", "assistant", "system", "result" as type values.
14
+
Control uses "control_request" and "control_response".
15
+
16
+
We use case_mem for all types. Note: we use the inner message codecs
17
+
(User.incoming_jsont, etc.) rather than Message.jsont to avoid nesting
18
+
case_mem on the same "type" field. *)
19
+
let case_control_request =
20
+
Jsont.Object.Case.map "control_request" Control.request_envelope_jsont
21
+
~dec:(fun v -> Control_request v)
22
+
in
23
+
let case_control_response =
24
+
Jsont.Object.Case.map "control_response" Control.response_envelope_jsont
25
+
~dec:(fun v -> Control_response v)
26
+
in
27
+
let case_user =
28
+
Jsont.Object.Case.map "user" Message.User.incoming_jsont ~dec:(fun v ->
29
+
Message (Message.User v))
30
+
in
31
+
let case_assistant =
32
+
Jsont.Object.Case.map "assistant" Message.Assistant.incoming_jsont
33
+
~dec:(fun v -> Message (Message.Assistant v))
34
+
in
35
+
let case_system =
36
+
Jsont.Object.Case.map "system" Message.System.jsont ~dec:(fun v ->
37
+
Message (Message.System v))
38
+
in
39
+
let case_result =
40
+
Jsont.Object.Case.map "result" Message.Result.jsont ~dec:(fun v ->
41
+
Message (Message.Result v))
42
+
in
43
+
let enc_case = function
44
+
| Control_request v -> Jsont.Object.Case.value case_control_request v
45
+
| Control_response v -> Jsont.Object.Case.value case_control_response v
46
+
| Message msg -> (
47
+
match msg with
48
+
| Message.User u -> Jsont.Object.Case.value case_user u
49
+
| Message.Assistant a -> Jsont.Object.Case.value case_assistant a
50
+
| Message.System s -> Jsont.Object.Case.value case_system s
51
+
| Message.Result r -> Jsont.Object.Case.value case_result r)
52
+
in
53
+
let cases =
54
+
Jsont.Object.Case.
55
+
[
56
+
make case_control_request;
57
+
make case_control_response;
58
+
make case_user;
59
+
make case_assistant;
60
+
make case_system;
61
+
make case_result;
62
+
]
63
+
in
64
+
Jsont.Object.map ~kind:"Incoming" Fun.id
65
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
66
+
~tag_to_string:Fun.id ~tag_compare:String.compare
67
+
|> Jsont.Object.finish
+21
proto/incoming.mli
+21
proto/incoming.mli
···
1
+
(** Incoming messages from the Claude CLI.
2
+
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
+
6
+
The codec uses the "type" field to discriminate between message types:
7
+
- "user", "assistant", "system", "result" -> Message variant
8
+
- "control_response" -> Control_response variant
9
+
- "control_request" -> Control_request variant
10
+
11
+
This provides a clean, type-safe way to decode incoming messages in a single
12
+
operation. *)
13
+
14
+
type t =
15
+
| Message of Message.t
16
+
| Control_response of Control.response_envelope
17
+
| Control_request of Control.request_envelope
18
+
19
+
val jsont : t Jsont.t
20
+
(** Codec for incoming messages. Uses the "type" field to discriminate. Use
21
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
+368
proto/message.ml
+368
proto/message.ml
···
1
+
module User = struct
2
+
type content = String of string | Blocks of Content_block.t list
3
+
type t = { content : content; unknown : Unknown.t }
4
+
5
+
let create_string s = { content = String s; unknown = Unknown.empty }
6
+
7
+
let create_blocks blocks =
8
+
{ content = Blocks blocks; unknown = Unknown.empty }
9
+
10
+
let create_with_tool_result ~tool_use_id ~content ?is_error () =
11
+
let tool_result =
12
+
Content_block.tool_result ~tool_use_id ~content ?is_error ()
13
+
in
14
+
{ content = Blocks [ tool_result ]; unknown = Unknown.empty }
15
+
16
+
let make content unknown = { content; unknown }
17
+
let content t = t.content
18
+
let unknown t = t.unknown
19
+
20
+
(* Decode content from json value *)
21
+
let decode_content json =
22
+
match json with
23
+
| Jsont.String (s, _) -> String s
24
+
| Jsont.Array (items, _) ->
25
+
let blocks =
26
+
List.map
27
+
(fun j ->
28
+
match Jsont.Json.decode Content_block.jsont j with
29
+
| Ok v -> v
30
+
| Error e -> invalid_arg ("Invalid content block: " ^ e))
31
+
items
32
+
in
33
+
Blocks blocks
34
+
| _ -> failwith "Content must be string or array"
35
+
36
+
(* Encode content to json value *)
37
+
let encode_content = function
38
+
| String s -> Jsont.String (s, Jsont.Meta.none)
39
+
| Blocks blocks ->
40
+
let jsons =
41
+
List.map
42
+
(fun b ->
43
+
match Jsont.Json.encode Content_block.jsont b with
44
+
| Ok json -> json
45
+
| Error e -> invalid_arg ("encode_content: " ^ e))
46
+
blocks
47
+
in
48
+
Jsont.Array (jsons, Jsont.Meta.none)
49
+
50
+
let jsont : t Jsont.t =
51
+
Jsont.Object.map ~kind:"User" (fun json_content unknown ->
52
+
let content = decode_content json_content in
53
+
make content unknown)
54
+
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t ->
55
+
encode_content (content t))
56
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
57
+
|> Jsont.Object.finish
58
+
59
+
(* Jsont codec for parsing incoming user messages from CLI *)
60
+
let incoming_jsont : t Jsont.t =
61
+
let message_jsont =
62
+
Jsont.Object.map ~kind:"UserMessage" (fun json_content ->
63
+
let content = decode_content json_content in
64
+
{ content; unknown = Unknown.empty })
65
+
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t ->
66
+
encode_content (content t))
67
+
|> Jsont.Object.finish
68
+
in
69
+
Jsont.Object.map ~kind:"UserEnvelope" Fun.id
70
+
|> Jsont.Object.mem "message" message_jsont ~enc:Fun.id
71
+
|> Jsont.Object.finish
72
+
73
+
(* Jsont codec for outgoing user messages - wraps in message envelope *)
74
+
let outgoing_jsont : t Jsont.t =
75
+
(* The inner message object with role and content *)
76
+
let message_jsont =
77
+
Jsont.Object.map ~kind:"UserOutgoingMessage" (fun _role json_content ->
78
+
let content = decode_content json_content in
79
+
{ content; unknown = Unknown.empty })
80
+
|> Jsont.Object.mem "role" Jsont.string ~enc:(fun _ -> "user")
81
+
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t ->
82
+
encode_content (content t))
83
+
|> Jsont.Object.finish
84
+
in
85
+
Jsont.Object.map ~kind:"UserOutgoingEnvelope" Fun.id
86
+
|> Jsont.Object.mem "message" message_jsont ~enc:Fun.id
87
+
|> Jsont.Object.finish
88
+
end
89
+
90
+
module Assistant = struct
91
+
type error =
92
+
[ `Authentication_failed
93
+
| `Billing_error
94
+
| `Rate_limit
95
+
| `Invalid_request
96
+
| `Server_error
97
+
| `Unknown ]
98
+
99
+
let error_jsont : error Jsont.t =
100
+
Jsont.enum
101
+
[
102
+
("authentication_failed", `Authentication_failed);
103
+
("billing_error", `Billing_error);
104
+
("rate_limit", `Rate_limit);
105
+
("invalid_request", `Invalid_request);
106
+
("server_error", `Server_error);
107
+
("unknown", `Unknown);
108
+
]
109
+
110
+
type t = {
111
+
content : Content_block.t list;
112
+
model : string;
113
+
error : error option;
114
+
unknown : Unknown.t;
115
+
}
116
+
117
+
let create ~content ~model ?error () =
118
+
{ content; model; error; unknown = Unknown.empty }
119
+
120
+
let make content model error unknown = { content; model; error; unknown }
121
+
let content t = t.content
122
+
let model t = t.model
123
+
let error t = t.error
124
+
let unknown t = t.unknown
125
+
126
+
let jsont : t Jsont.t =
127
+
Jsont.Object.map ~kind:"Assistant" make
128
+
|> Jsont.Object.mem "content" (Jsont.list Content_block.jsont) ~enc:content
129
+
|> Jsont.Object.mem "model" Jsont.string ~enc:model
130
+
|> Jsont.Object.opt_mem "error" error_jsont ~enc:error
131
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
132
+
|> Jsont.Object.finish
133
+
134
+
(* Jsont codec for parsing incoming assistant messages from CLI *)
135
+
let incoming_jsont : t Jsont.t =
136
+
Jsont.Object.map ~kind:"AssistantEnvelope" Fun.id
137
+
|> Jsont.Object.mem "message" jsont ~enc:Fun.id
138
+
|> Jsont.Object.finish
139
+
end
140
+
141
+
module System = struct
142
+
(** System messages as a discriminated union on "subtype" field *)
143
+
144
+
type init = {
145
+
session_id : string option;
146
+
model : string option;
147
+
cwd : string option;
148
+
unknown : Unknown.t;
149
+
}
150
+
151
+
type error = { error : string; unknown : Unknown.t }
152
+
type t = Init of init | Error of error
153
+
154
+
(* Accessors *)
155
+
let session_id = function Init i -> i.session_id | _ -> None
156
+
let model = function Init i -> i.model | _ -> None
157
+
let cwd = function Init i -> i.cwd | _ -> None
158
+
let error_msg = function Error e -> Some e.error | _ -> None
159
+
let unknown = function Init i -> i.unknown | Error e -> e.unknown
160
+
161
+
(* Constructors *)
162
+
let init ?session_id ?model ?cwd () =
163
+
Init { session_id; model; cwd; unknown = Unknown.empty }
164
+
165
+
let error ~error = Error { error; unknown = Unknown.empty }
166
+
167
+
(* Individual record codecs *)
168
+
let init_jsont : init Jsont.t =
169
+
let make session_id model cwd unknown : init =
170
+
{ session_id; model; cwd; unknown }
171
+
in
172
+
Jsont.Object.map ~kind:"SystemInit" make
173
+
|> Jsont.Object.opt_mem "session_id" Jsont.string ~enc:(fun (r : init) ->
174
+
r.session_id)
175
+
|> Jsont.Object.opt_mem "model" Jsont.string ~enc:(fun (r : init) ->
176
+
r.model)
177
+
|> Jsont.Object.opt_mem "cwd" Jsont.string ~enc:(fun (r : init) -> r.cwd)
178
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : init) ->
179
+
r.unknown)
180
+
|> Jsont.Object.finish
181
+
182
+
let error_jsont : error Jsont.t =
183
+
let make err unknown : error = { error = err; unknown } in
184
+
Jsont.Object.map ~kind:"SystemError" make
185
+
|> Jsont.Object.mem "error" Jsont.string ~enc:(fun (r : error) -> r.error)
186
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : error) ->
187
+
r.unknown)
188
+
|> Jsont.Object.finish
189
+
190
+
(* Main codec using case_mem for "subtype" discriminator *)
191
+
let jsont : t Jsont.t =
192
+
let case_init =
193
+
Jsont.Object.Case.map "init" init_jsont ~dec:(fun v -> Init v)
194
+
in
195
+
let case_error =
196
+
Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
197
+
in
198
+
let enc_case = function
199
+
| Init v -> Jsont.Object.Case.value case_init v
200
+
| Error v -> Jsont.Object.Case.value case_error v
201
+
in
202
+
let cases = Jsont.Object.Case.[ make case_init; make case_error ] in
203
+
Jsont.Object.map ~kind:"System" Fun.id
204
+
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
205
+
~tag_to_string:Fun.id ~tag_compare:String.compare
206
+
|> Jsont.Object.finish
207
+
end
208
+
209
+
module Result = struct
210
+
module Usage = struct
211
+
type t = {
212
+
input_tokens : int option;
213
+
output_tokens : int option;
214
+
total_tokens : int option;
215
+
cache_creation_input_tokens : int option;
216
+
cache_read_input_tokens : int option;
217
+
unknown : Unknown.t;
218
+
}
219
+
220
+
let make input_tokens output_tokens total_tokens cache_creation_input_tokens
221
+
cache_read_input_tokens unknown =
222
+
{
223
+
input_tokens;
224
+
output_tokens;
225
+
total_tokens;
226
+
cache_creation_input_tokens;
227
+
cache_read_input_tokens;
228
+
unknown;
229
+
}
230
+
231
+
let create ?input_tokens ?output_tokens ?total_tokens
232
+
?cache_creation_input_tokens ?cache_read_input_tokens () =
233
+
{
234
+
input_tokens;
235
+
output_tokens;
236
+
total_tokens;
237
+
cache_creation_input_tokens;
238
+
cache_read_input_tokens;
239
+
unknown = Unknown.empty;
240
+
}
241
+
242
+
let input_tokens t = t.input_tokens
243
+
let output_tokens t = t.output_tokens
244
+
let total_tokens t = t.total_tokens
245
+
let cache_creation_input_tokens t = t.cache_creation_input_tokens
246
+
let cache_read_input_tokens t = t.cache_read_input_tokens
247
+
let unknown t = t.unknown
248
+
249
+
let jsont : t Jsont.t =
250
+
Jsont.Object.map ~kind:"Usage" make
251
+
|> Jsont.Object.opt_mem "input_tokens" Jsont.int ~enc:input_tokens
252
+
|> Jsont.Object.opt_mem "output_tokens" Jsont.int ~enc:output_tokens
253
+
|> Jsont.Object.opt_mem "total_tokens" Jsont.int ~enc:total_tokens
254
+
|> Jsont.Object.opt_mem "cache_creation_input_tokens" Jsont.int
255
+
~enc:cache_creation_input_tokens
256
+
|> Jsont.Object.opt_mem "cache_read_input_tokens" Jsont.int
257
+
~enc:cache_read_input_tokens
258
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
259
+
|> Jsont.Object.finish
260
+
end
261
+
262
+
type t = {
263
+
subtype : string;
264
+
duration_ms : int;
265
+
duration_api_ms : int;
266
+
is_error : bool;
267
+
num_turns : int;
268
+
session_id : string;
269
+
total_cost_usd : float option;
270
+
usage : Usage.t option;
271
+
result : string option;
272
+
structured_output : Jsont.json option;
273
+
unknown : Unknown.t;
274
+
}
275
+
276
+
let create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
277
+
~session_id ?total_cost_usd ?usage ?result ?structured_output () =
278
+
{
279
+
subtype;
280
+
duration_ms;
281
+
duration_api_ms;
282
+
is_error;
283
+
num_turns;
284
+
session_id;
285
+
total_cost_usd;
286
+
usage;
287
+
result;
288
+
structured_output;
289
+
unknown = Unknown.empty;
290
+
}
291
+
292
+
let make subtype duration_ms duration_api_ms is_error num_turns session_id
293
+
total_cost_usd usage result structured_output unknown =
294
+
{
295
+
subtype;
296
+
duration_ms;
297
+
duration_api_ms;
298
+
is_error;
299
+
num_turns;
300
+
session_id;
301
+
total_cost_usd;
302
+
usage;
303
+
result;
304
+
structured_output;
305
+
unknown;
306
+
}
307
+
308
+
let subtype t = t.subtype
309
+
let duration_ms t = t.duration_ms
310
+
let duration_api_ms t = t.duration_api_ms
311
+
let is_error t = t.is_error
312
+
let num_turns t = t.num_turns
313
+
let session_id t = t.session_id
314
+
let total_cost_usd t = t.total_cost_usd
315
+
let usage t = t.usage
316
+
let result t = t.result
317
+
let structured_output t = t.structured_output
318
+
let unknown t = t.unknown
319
+
320
+
let jsont : t Jsont.t =
321
+
Jsont.Object.map ~kind:"Result" make
322
+
|> Jsont.Object.mem "subtype" Jsont.string ~enc:subtype
323
+
|> Jsont.Object.mem "duration_ms" Jsont.int ~enc:duration_ms
324
+
|> Jsont.Object.mem "duration_api_ms" Jsont.int ~enc:duration_api_ms
325
+
|> Jsont.Object.mem "is_error" Jsont.bool ~enc:is_error
326
+
|> Jsont.Object.mem "num_turns" Jsont.int ~enc:num_turns
327
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
328
+
|> Jsont.Object.opt_mem "total_cost_usd" Jsont.number ~enc:total_cost_usd
329
+
|> Jsont.Object.opt_mem "usage" Usage.jsont ~enc:usage
330
+
|> Jsont.Object.opt_mem "result" Jsont.string ~enc:result
331
+
|> Jsont.Object.opt_mem "structured_output" Jsont.json
332
+
~enc:structured_output
333
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
334
+
|> Jsont.Object.finish
335
+
end
336
+
337
+
type t =
338
+
| User of User.t
339
+
| Assistant of Assistant.t
340
+
| System of System.t
341
+
| Result of Result.t
342
+
343
+
(* Jsont codec for the main Message variant type.
344
+
Uses case_mem for discriminated union based on "type" field. *)
345
+
let jsont : t Jsont.t =
346
+
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
347
+
let case_user = case_map "user" User.incoming_jsont (fun v -> User v) in
348
+
let case_assistant =
349
+
case_map "assistant" Assistant.incoming_jsont (fun v -> Assistant v)
350
+
in
351
+
let case_system = case_map "system" System.jsont (fun v -> System v) in
352
+
let case_result = case_map "result" Result.jsont (fun v -> Result v) in
353
+
let enc_case = function
354
+
| User v -> Jsont.Object.Case.value case_user v
355
+
| Assistant v -> Jsont.Object.Case.value case_assistant v
356
+
| System v -> Jsont.Object.Case.value case_system v
357
+
| Result v -> Jsont.Object.Case.value case_result v
358
+
in
359
+
let cases =
360
+
Jsont.Object.Case.
361
+
[
362
+
make case_user; make case_assistant; make case_system; make case_result;
363
+
]
364
+
in
365
+
Jsont.Object.map ~kind:"Message" Fun.id
366
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
367
+
~tag_to_string:Fun.id ~tag_compare:String.compare
368
+
|> Jsont.Object.finish
+352
proto/message.ml.bak
+352
proto/message.ml.bak
···
1
+
module User = struct
2
+
type content = String of string | Blocks of Content_block.t list
3
+
type t = { content : content; unknown : Unknown.t }
4
+
5
+
let create_string s = { content = String s; unknown = Unknown.empty }
6
+
7
+
let create_blocks blocks =
8
+
{ content = Blocks blocks; unknown = Unknown.empty }
9
+
10
+
let create_with_tool_result ~tool_use_id ~content ?is_error () =
11
+
let tool_result =
12
+
Content_block.tool_result ~tool_use_id ~content ?is_error ()
13
+
in
14
+
{ content = Blocks [ tool_result ]; unknown = Unknown.empty }
15
+
16
+
let make content unknown = { content; unknown }
17
+
let content t = t.content
18
+
let unknown t = t.unknown
19
+
20
+
(* Decode content from json value *)
21
+
let decode_content json =
22
+
match json with
23
+
| Jsont.String (s, _) -> String s
24
+
| Jsont.Array (items, _) ->
25
+
let blocks =
26
+
List.map
27
+
(fun j ->
28
+
match Jsont.Json.decode Content_block.jsont j with
29
+
| Ok v -> v
30
+
| Error e -> invalid_arg ("Invalid content block: " ^ e))
31
+
items
32
+
in
33
+
Blocks blocks
34
+
| _ -> failwith "Content must be string or array"
35
+
36
+
(* Encode content to json value *)
37
+
let encode_content = function
38
+
| String s -> Jsont.String (s, Jsont.Meta.none)
39
+
| Blocks blocks ->
40
+
let jsons =
41
+
List.map
42
+
(fun b ->
43
+
match Jsont.Json.encode Content_block.jsont b with
44
+
| Ok json -> json
45
+
| Error e -> invalid_arg ("encode_content: " ^ e))
46
+
blocks
47
+
in
48
+
Jsont.Array (jsons, Jsont.Meta.none)
49
+
50
+
let jsont : t Jsont.t =
51
+
Jsont.Object.map ~kind:"User" (fun json_content unknown ->
52
+
let content = decode_content json_content in
53
+
make content unknown)
54
+
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t ->
55
+
encode_content (content t))
56
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
57
+
|> Jsont.Object.finish
58
+
59
+
(* Jsont codec for parsing incoming user messages from CLI *)
60
+
let incoming_jsont : t Jsont.t =
61
+
let message_jsont =
62
+
Jsont.Object.map ~kind:"UserMessage" (fun json_content ->
63
+
let content = decode_content json_content in
64
+
{ content; unknown = Unknown.empty })
65
+
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t ->
66
+
encode_content (content t))
67
+
|> Jsont.Object.finish
68
+
in
69
+
Jsont.Object.map ~kind:"UserEnvelope" Fun.id
70
+
|> Jsont.Object.mem "message" message_jsont ~enc:Fun.id
71
+
|> Jsont.Object.finish
72
+
end
73
+
74
+
module Assistant = struct
75
+
type error =
76
+
[ `Authentication_failed
77
+
| `Billing_error
78
+
| `Rate_limit
79
+
| `Invalid_request
80
+
| `Server_error
81
+
| `Unknown ]
82
+
83
+
let error_jsont : error Jsont.t =
84
+
Jsont.enum
85
+
[
86
+
("authentication_failed", `Authentication_failed);
87
+
("billing_error", `Billing_error);
88
+
("rate_limit", `Rate_limit);
89
+
("invalid_request", `Invalid_request);
90
+
("server_error", `Server_error);
91
+
("unknown", `Unknown);
92
+
]
93
+
94
+
type t = {
95
+
content : Content_block.t list;
96
+
model : string;
97
+
error : error option;
98
+
unknown : Unknown.t;
99
+
}
100
+
101
+
let create ~content ~model ?error () =
102
+
{ content; model; error; unknown = Unknown.empty }
103
+
104
+
let make content model error unknown = { content; model; error; unknown }
105
+
let content t = t.content
106
+
let model t = t.model
107
+
let error t = t.error
108
+
let unknown t = t.unknown
109
+
110
+
let jsont : t Jsont.t =
111
+
Jsont.Object.map ~kind:"Assistant" make
112
+
|> Jsont.Object.mem "content" (Jsont.list Content_block.jsont) ~enc:content
113
+
|> Jsont.Object.mem "model" Jsont.string ~enc:model
114
+
|> Jsont.Object.opt_mem "error" error_jsont ~enc:error
115
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
116
+
|> Jsont.Object.finish
117
+
118
+
(* Jsont codec for parsing incoming assistant messages from CLI *)
119
+
let incoming_jsont : t Jsont.t =
120
+
Jsont.Object.map ~kind:"AssistantEnvelope" Fun.id
121
+
|> Jsont.Object.mem "message" jsont ~enc:Fun.id
122
+
|> Jsont.Object.finish
123
+
end
124
+
125
+
module System = struct
126
+
(** System messages as a discriminated union on "subtype" field *)
127
+
128
+
type init = {
129
+
session_id : string option;
130
+
model : string option;
131
+
cwd : string option;
132
+
unknown : Unknown.t;
133
+
}
134
+
135
+
type error = { error : string; unknown : Unknown.t }
136
+
type t = Init of init | Error of error
137
+
138
+
(* Accessors *)
139
+
let session_id = function Init i -> i.session_id | _ -> None
140
+
let model = function Init i -> i.model | _ -> None
141
+
let cwd = function Init i -> i.cwd | _ -> None
142
+
let error_msg = function Error e -> Some e.error | _ -> None
143
+
let unknown = function Init i -> i.unknown | Error e -> e.unknown
144
+
145
+
(* Constructors *)
146
+
let init ?session_id ?model ?cwd () =
147
+
Init { session_id; model; cwd; unknown = Unknown.empty }
148
+
149
+
let error ~error = Error { error; unknown = Unknown.empty }
150
+
151
+
(* Individual record codecs *)
152
+
let init_jsont : init Jsont.t =
153
+
let make session_id model cwd unknown : init =
154
+
{ session_id; model; cwd; unknown }
155
+
in
156
+
Jsont.Object.map ~kind:"SystemInit" make
157
+
|> Jsont.Object.opt_mem "session_id" Jsont.string ~enc:(fun (r : init) ->
158
+
r.session_id)
159
+
|> Jsont.Object.opt_mem "model" Jsont.string ~enc:(fun (r : init) ->
160
+
r.model)
161
+
|> Jsont.Object.opt_mem "cwd" Jsont.string ~enc:(fun (r : init) -> r.cwd)
162
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : init) ->
163
+
r.unknown)
164
+
|> Jsont.Object.finish
165
+
166
+
let error_jsont : error Jsont.t =
167
+
let make err unknown : error = { error = err; unknown } in
168
+
Jsont.Object.map ~kind:"SystemError" make
169
+
|> Jsont.Object.mem "error" Jsont.string ~enc:(fun (r : error) -> r.error)
170
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : error) ->
171
+
r.unknown)
172
+
|> Jsont.Object.finish
173
+
174
+
(* Main codec using case_mem for "subtype" discriminator *)
175
+
let jsont : t Jsont.t =
176
+
let case_init =
177
+
Jsont.Object.Case.map "init" init_jsont ~dec:(fun v -> Init v)
178
+
in
179
+
let case_error =
180
+
Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
181
+
in
182
+
let enc_case = function
183
+
| Init v -> Jsont.Object.Case.value case_init v
184
+
| Error v -> Jsont.Object.Case.value case_error v
185
+
in
186
+
let cases = Jsont.Object.Case.[ make case_init; make case_error ] in
187
+
Jsont.Object.map ~kind:"System" Fun.id
188
+
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
189
+
~tag_to_string:Fun.id ~tag_compare:String.compare
190
+
|> Jsont.Object.finish
191
+
end
192
+
193
+
module Result = struct
194
+
module Usage = struct
195
+
type t = {
196
+
input_tokens : int option;
197
+
output_tokens : int option;
198
+
total_tokens : int option;
199
+
cache_creation_input_tokens : int option;
200
+
cache_read_input_tokens : int option;
201
+
unknown : Unknown.t;
202
+
}
203
+
204
+
let make input_tokens output_tokens total_tokens cache_creation_input_tokens
205
+
cache_read_input_tokens unknown =
206
+
{
207
+
input_tokens;
208
+
output_tokens;
209
+
total_tokens;
210
+
cache_creation_input_tokens;
211
+
cache_read_input_tokens;
212
+
unknown;
213
+
}
214
+
215
+
let create ?input_tokens ?output_tokens ?total_tokens
216
+
?cache_creation_input_tokens ?cache_read_input_tokens () =
217
+
{
218
+
input_tokens;
219
+
output_tokens;
220
+
total_tokens;
221
+
cache_creation_input_tokens;
222
+
cache_read_input_tokens;
223
+
unknown = Unknown.empty;
224
+
}
225
+
226
+
let input_tokens t = t.input_tokens
227
+
let output_tokens t = t.output_tokens
228
+
let total_tokens t = t.total_tokens
229
+
let cache_creation_input_tokens t = t.cache_creation_input_tokens
230
+
let cache_read_input_tokens t = t.cache_read_input_tokens
231
+
let unknown t = t.unknown
232
+
233
+
let jsont : t Jsont.t =
234
+
Jsont.Object.map ~kind:"Usage" make
235
+
|> Jsont.Object.opt_mem "input_tokens" Jsont.int ~enc:input_tokens
236
+
|> Jsont.Object.opt_mem "output_tokens" Jsont.int ~enc:output_tokens
237
+
|> Jsont.Object.opt_mem "total_tokens" Jsont.int ~enc:total_tokens
238
+
|> Jsont.Object.opt_mem "cache_creation_input_tokens" Jsont.int
239
+
~enc:cache_creation_input_tokens
240
+
|> Jsont.Object.opt_mem "cache_read_input_tokens" Jsont.int
241
+
~enc:cache_read_input_tokens
242
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
243
+
|> Jsont.Object.finish
244
+
end
245
+
246
+
type t = {
247
+
subtype : string;
248
+
duration_ms : int;
249
+
duration_api_ms : int;
250
+
is_error : bool;
251
+
num_turns : int;
252
+
session_id : string;
253
+
total_cost_usd : float option;
254
+
usage : Usage.t option;
255
+
result : string option;
256
+
structured_output : Jsont.json option;
257
+
unknown : Unknown.t;
258
+
}
259
+
260
+
let create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
261
+
~session_id ?total_cost_usd ?usage ?result ?structured_output () =
262
+
{
263
+
subtype;
264
+
duration_ms;
265
+
duration_api_ms;
266
+
is_error;
267
+
num_turns;
268
+
session_id;
269
+
total_cost_usd;
270
+
usage;
271
+
result;
272
+
structured_output;
273
+
unknown = Unknown.empty;
274
+
}
275
+
276
+
let make subtype duration_ms duration_api_ms is_error num_turns session_id
277
+
total_cost_usd usage result structured_output unknown =
278
+
{
279
+
subtype;
280
+
duration_ms;
281
+
duration_api_ms;
282
+
is_error;
283
+
num_turns;
284
+
session_id;
285
+
total_cost_usd;
286
+
usage;
287
+
result;
288
+
structured_output;
289
+
unknown;
290
+
}
291
+
292
+
let subtype t = t.subtype
293
+
let duration_ms t = t.duration_ms
294
+
let duration_api_ms t = t.duration_api_ms
295
+
let is_error t = t.is_error
296
+
let num_turns t = t.num_turns
297
+
let session_id t = t.session_id
298
+
let total_cost_usd t = t.total_cost_usd
299
+
let usage t = t.usage
300
+
let result t = t.result
301
+
let structured_output t = t.structured_output
302
+
let unknown t = t.unknown
303
+
304
+
let jsont : t Jsont.t =
305
+
Jsont.Object.map ~kind:"Result" make
306
+
|> Jsont.Object.mem "subtype" Jsont.string ~enc:subtype
307
+
|> Jsont.Object.mem "duration_ms" Jsont.int ~enc:duration_ms
308
+
|> Jsont.Object.mem "duration_api_ms" Jsont.int ~enc:duration_api_ms
309
+
|> Jsont.Object.mem "is_error" Jsont.bool ~enc:is_error
310
+
|> Jsont.Object.mem "num_turns" Jsont.int ~enc:num_turns
311
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
312
+
|> Jsont.Object.opt_mem "total_cost_usd" Jsont.number ~enc:total_cost_usd
313
+
|> Jsont.Object.opt_mem "usage" Usage.jsont ~enc:usage
314
+
|> Jsont.Object.opt_mem "result" Jsont.string ~enc:result
315
+
|> Jsont.Object.opt_mem "structured_output" Jsont.json
316
+
~enc:structured_output
317
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
318
+
|> Jsont.Object.finish
319
+
end
320
+
321
+
type t =
322
+
| User of User.t
323
+
| Assistant of Assistant.t
324
+
| System of System.t
325
+
| Result of Result.t
326
+
327
+
(* Jsont codec for the main Message variant type.
328
+
Uses case_mem for discriminated union based on "type" field. *)
329
+
let jsont : t Jsont.t =
330
+
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
331
+
let case_user = case_map "user" User.incoming_jsont (fun v -> User v) in
332
+
let case_assistant =
333
+
case_map "assistant" Assistant.incoming_jsont (fun v -> Assistant v)
334
+
in
335
+
let case_system = case_map "system" System.jsont (fun v -> System v) in
336
+
let case_result = case_map "result" Result.jsont (fun v -> Result v) in
337
+
let enc_case = function
338
+
| User v -> Jsont.Object.Case.value case_user v
339
+
| Assistant v -> Jsont.Object.Case.value case_assistant v
340
+
| System v -> Jsont.Object.Case.value case_system v
341
+
| Result v -> Jsont.Object.Case.value case_result v
342
+
in
343
+
let cases =
344
+
Jsont.Object.Case.
345
+
[
346
+
make case_user; make case_assistant; make case_system; make case_result;
347
+
]
348
+
in
349
+
Jsont.Object.map ~kind:"Message" Fun.id
350
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
351
+
~tag_to_string:Fun.id ~tag_compare:String.compare
352
+
|> Jsont.Object.finish
+270
proto/message.mli
+270
proto/message.mli
···
1
+
(** Messages exchanged with Claude wire format.
2
+
3
+
This module defines the wire format types for messages that can be sent to
4
+
and received from Claude, including user input, assistant responses, system
5
+
messages, and result metadata. *)
6
+
7
+
(** {1 User Messages} *)
8
+
9
+
module User : sig
10
+
(** Messages sent by the user. *)
11
+
12
+
(** The content of a user message. *)
13
+
type content =
14
+
| String of string (** Simple text message *)
15
+
| Blocks of Content_block.t list
16
+
(** Complex message with multiple content blocks *)
17
+
18
+
type t
19
+
(** The type of user messages. *)
20
+
21
+
val jsont : t Jsont.t
22
+
(** [jsont] is the Jsont codec for user messages. *)
23
+
24
+
val incoming_jsont : t Jsont.t
25
+
(** [incoming_jsont] is the codec for parsing incoming user messages from CLI.
26
+
This parses the envelope format with "message" wrapper. *)
27
+
28
+
val outgoing_jsont : t Jsont.t
29
+
(** [outgoing_jsont] is the codec for encoding outgoing user messages to CLI.
30
+
This produces the envelope format with "message" wrapper containing
31
+
"role" and "content" fields. *)
32
+
33
+
val create_string : string -> t
34
+
(** [create_string s] creates a user message with simple text content. *)
35
+
36
+
val create_blocks : Content_block.t list -> t
37
+
(** [create_blocks blocks] creates a user message with content blocks. *)
38
+
39
+
val create_with_tool_result :
40
+
tool_use_id:string -> content:string -> ?is_error:bool -> unit -> t
41
+
(** [create_with_tool_result ~tool_use_id ~content ?is_error ()] creates a
42
+
user message containing a tool result. *)
43
+
44
+
val content : t -> content
45
+
(** [content t] returns the content of the user message. *)
46
+
47
+
val unknown : t -> Unknown.t
48
+
(** [unknown t] returns the unknown fields preserved from JSON. *)
49
+
end
50
+
51
+
(** {1 Assistant Messages} *)
52
+
53
+
module Assistant : sig
54
+
(** Messages from Claude assistant. *)
55
+
56
+
type error =
57
+
[ `Authentication_failed (** Authentication with Claude API failed *)
58
+
| `Billing_error (** Billing or account issue *)
59
+
| `Rate_limit (** Rate limit exceeded *)
60
+
| `Invalid_request (** Request was invalid *)
61
+
| `Server_error (** Internal server error *)
62
+
| `Unknown (** Unknown error type *) ]
63
+
(** The type of assistant message errors based on Python SDK error types. *)
64
+
65
+
type t
66
+
(** The type of assistant messages. *)
67
+
68
+
val jsont : t Jsont.t
69
+
(** [jsont] is the Jsont codec for assistant messages. *)
70
+
71
+
val incoming_jsont : t Jsont.t
72
+
(** [incoming_jsont] is the codec for parsing incoming assistant messages from
73
+
CLI. This parses the envelope format with "message" wrapper. *)
74
+
75
+
val create :
76
+
content:Content_block.t list -> model:string -> ?error:error -> unit -> t
77
+
(** [create ~content ~model ?error ()] creates an assistant message.
78
+
@param content List of content blocks in the response
79
+
@param model The model identifier used for the response
80
+
@param error Optional error that occurred during message generation *)
81
+
82
+
val content : t -> Content_block.t list
83
+
(** [content t] returns the content blocks of the assistant message. *)
84
+
85
+
val model : t -> string
86
+
(** [model t] returns the model identifier. *)
87
+
88
+
val error : t -> error option
89
+
(** [error t] returns the optional error that occurred during message
90
+
generation. *)
91
+
92
+
val unknown : t -> Unknown.t
93
+
(** [unknown t] returns the unknown fields preserved from JSON. *)
94
+
end
95
+
96
+
(** {1 System Messages} *)
97
+
98
+
module System : sig
99
+
(** System control and status messages.
100
+
101
+
System messages use a discriminated union on the "subtype" field:
102
+
- "init": Session initialization with session_id, model, cwd
103
+
- "error": Error messages with error string *)
104
+
105
+
type init = {
106
+
session_id : string option;
107
+
model : string option;
108
+
cwd : string option;
109
+
unknown : Unknown.t;
110
+
}
111
+
(** Init message fields. *)
112
+
113
+
type error = { error : string; unknown : Unknown.t }
114
+
(** Error message fields. *)
115
+
116
+
type t = Init of init | Error of error
117
+
118
+
val jsont : t Jsont.t
119
+
(** [jsont] is the Jsont codec for system messages. *)
120
+
121
+
(** {2 Constructors} *)
122
+
123
+
val init : ?session_id:string -> ?model:string -> ?cwd:string -> unit -> t
124
+
(** [init ?session_id ?model ?cwd ()] creates an init message. *)
125
+
126
+
val error : error:string -> t
127
+
(** [error ~error] creates an error message. *)
128
+
129
+
(** {2 Accessors} *)
130
+
131
+
val session_id : t -> string option
132
+
(** [session_id t] returns session_id from Init, None otherwise. *)
133
+
134
+
val model : t -> string option
135
+
(** [model t] returns model from Init, None otherwise. *)
136
+
137
+
val cwd : t -> string option
138
+
(** [cwd t] returns cwd from Init, None otherwise. *)
139
+
140
+
val error_msg : t -> string option
141
+
(** [error_msg t] returns error from Error, None otherwise. *)
142
+
143
+
val unknown : t -> Unknown.t
144
+
(** [unknown t] returns the unknown fields. *)
145
+
end
146
+
147
+
(** {1 Result Messages} *)
148
+
149
+
module Result : sig
150
+
(** Final result messages with metadata about the conversation. *)
151
+
152
+
module Usage : sig
153
+
(** Usage statistics for API calls. *)
154
+
155
+
type t
156
+
(** Type for usage statistics. *)
157
+
158
+
val jsont : t Jsont.t
159
+
(** [jsont] is the Jsont codec for usage statistics. *)
160
+
161
+
val create :
162
+
?input_tokens:int ->
163
+
?output_tokens:int ->
164
+
?total_tokens:int ->
165
+
?cache_creation_input_tokens:int ->
166
+
?cache_read_input_tokens:int ->
167
+
unit ->
168
+
t
169
+
(** [create ?input_tokens ?output_tokens ?total_tokens
170
+
?cache_creation_input_tokens ?cache_read_input_tokens ()] creates usage
171
+
statistics. *)
172
+
173
+
val input_tokens : t -> int option
174
+
(** [input_tokens t] returns the number of input tokens used. *)
175
+
176
+
val output_tokens : t -> int option
177
+
(** [output_tokens t] returns the number of output tokens generated. *)
178
+
179
+
val total_tokens : t -> int option
180
+
(** [total_tokens t] returns the total number of tokens. *)
181
+
182
+
val cache_creation_input_tokens : t -> int option
183
+
(** [cache_creation_input_tokens t] returns cache creation input tokens. *)
184
+
185
+
val cache_read_input_tokens : t -> int option
186
+
(** [cache_read_input_tokens t] returns cache read input tokens. *)
187
+
188
+
val unknown : t -> Unknown.t
189
+
(** [unknown t] returns the unknown fields preserved from JSON. *)
190
+
end
191
+
192
+
type t
193
+
(** The type of result messages. *)
194
+
195
+
val jsont : t Jsont.t
196
+
(** [jsont] is the Jsont codec for result messages. *)
197
+
198
+
val create :
199
+
subtype:string ->
200
+
duration_ms:int ->
201
+
duration_api_ms:int ->
202
+
is_error:bool ->
203
+
num_turns:int ->
204
+
session_id:string ->
205
+
?total_cost_usd:float ->
206
+
?usage:Usage.t ->
207
+
?result:string ->
208
+
?structured_output:Jsont.json ->
209
+
unit ->
210
+
t
211
+
(** [create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
212
+
~session_id ?total_cost_usd ?usage ?result ?structured_output ()] creates
213
+
a result message.
214
+
@param subtype The subtype of the result
215
+
@param duration_ms Total duration in milliseconds
216
+
@param duration_api_ms API duration in milliseconds
217
+
@param is_error Whether the result represents an error
218
+
@param num_turns Number of conversation turns
219
+
@param session_id Unique session identifier
220
+
@param total_cost_usd Optional total cost in USD
221
+
@param usage Optional usage statistics
222
+
@param result Optional result string
223
+
@param structured_output Optional structured JSON output from Claude *)
224
+
225
+
val subtype : t -> string
226
+
(** [subtype t] returns the subtype of the result. *)
227
+
228
+
val duration_ms : t -> int
229
+
(** [duration_ms t] returns the total duration in milliseconds. *)
230
+
231
+
val duration_api_ms : t -> int
232
+
(** [duration_api_ms t] returns the API duration in milliseconds. *)
233
+
234
+
val is_error : t -> bool
235
+
(** [is_error t] returns whether this result represents an error. *)
236
+
237
+
val num_turns : t -> int
238
+
(** [num_turns t] returns the number of conversation turns. *)
239
+
240
+
val session_id : t -> string
241
+
(** [session_id t] returns the session identifier. *)
242
+
243
+
val total_cost_usd : t -> float option
244
+
(** [total_cost_usd t] returns the optional total cost in USD. *)
245
+
246
+
val usage : t -> Usage.t option
247
+
(** [usage t] returns the optional usage statistics. *)
248
+
249
+
val result : t -> string option
250
+
(** [result t] returns the optional result string. *)
251
+
252
+
val structured_output : t -> Jsont.json option
253
+
(** [structured_output t] returns the optional structured JSON output. *)
254
+
255
+
val unknown : t -> Unknown.t
256
+
(** [unknown t] returns the unknown fields preserved from JSON. *)
257
+
end
258
+
259
+
(** {1 Message Union Type} *)
260
+
261
+
type t =
262
+
| User of User.t
263
+
| Assistant of Assistant.t
264
+
| System of System.t
265
+
| Result of Result.t
266
+
(** The type of messages, which can be user, assistant, system, or result.
267
+
*)
268
+
269
+
val jsont : t Jsont.t
270
+
(** [jsont] is the Jsont codec for messages. *)
+26
proto/model.ml
+26
proto/model.ml
···
1
+
type t =
2
+
[ `Sonnet_4_5
3
+
| `Sonnet_4
4
+
| `Sonnet_3_5
5
+
| `Opus_4
6
+
| `Haiku_4
7
+
| `Custom of string ]
8
+
9
+
let to_string = function
10
+
| `Sonnet_4_5 -> "claude-sonnet-4-5"
11
+
| `Sonnet_4 -> "claude-sonnet-4"
12
+
| `Sonnet_3_5 -> "claude-sonnet-3-5"
13
+
| `Opus_4 -> "claude-opus-4"
14
+
| `Haiku_4 -> "claude-haiku-4"
15
+
| `Custom s -> s
16
+
17
+
let of_string = function
18
+
| "claude-sonnet-4-5" -> `Sonnet_4_5
19
+
| "claude-sonnet-4" -> `Sonnet_4
20
+
| "claude-sonnet-3-5" -> `Sonnet_3_5
21
+
| "claude-opus-4" -> `Opus_4
22
+
| "claude-haiku-4" -> `Haiku_4
23
+
| s -> `Custom s
24
+
25
+
let jsont : t Jsont.t =
26
+
Jsont.map ~kind:"Model" ~dec:of_string ~enc:to_string Jsont.string
+38
proto/model.mli
+38
proto/model.mli
···
1
+
(** Claude AI model identifiers for protocol encoding.
2
+
3
+
This module provides type-safe model identifiers with JSON encoding/decoding
4
+
support via Jsont. Use polymorphic variants for known models with a custom
5
+
escape hatch for future or unknown models. *)
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
+
(** The type of Claude models. *)
15
+
16
+
val to_string : t -> string
17
+
(** [to_string t] converts a model to its string representation.
18
+
19
+
Examples:
20
+
- [`Sonnet_4_5] becomes "claude-sonnet-4-5"
21
+
- [`Opus_4] becomes "claude-opus-4"
22
+
- [`Custom "my-model"] becomes "my-model" *)
23
+
24
+
val of_string : string -> t
25
+
(** [of_string s] parses a model string into a typed model.
26
+
27
+
Known model strings are converted to their typed variants. Unknown strings
28
+
become [`Custom s].
29
+
30
+
Examples:
31
+
- "claude-sonnet-4-5" becomes [`Sonnet_4_5]
32
+
- "future-model" becomes [`Custom "future-model"] *)
33
+
34
+
val jsont : t Jsont.t
35
+
(** [jsont] is the Jsont codec for model identifiers.
36
+
37
+
This codec maps between the typed model representation and JSON strings. It
38
+
uses [of_string] for decoding and [to_string] for encoding. *)
+182
proto/options.ml
+182
proto/options.ml
···
1
+
(** Wire format for Claude configuration options. *)
2
+
3
+
(** Setting sources *)
4
+
type setting_source = User | Project | Local
5
+
6
+
let setting_source_jsont : setting_source Jsont.t =
7
+
Jsont.enum [ ("user", User); ("project", Project); ("local", Local) ]
8
+
9
+
(** Configuration type *)
10
+
type t = {
11
+
allowed_tools : string list;
12
+
disallowed_tools : string list;
13
+
max_thinking_tokens : int option;
14
+
system_prompt : string option;
15
+
append_system_prompt : string option;
16
+
permission_mode : Permissions.Mode.t option;
17
+
model : Model.t option;
18
+
continue_conversation : bool;
19
+
resume : string option;
20
+
max_turns : int option;
21
+
permission_prompt_tool_name : string option;
22
+
settings : string option;
23
+
add_dirs : string list;
24
+
max_budget_usd : float option;
25
+
fallback_model : Model.t option;
26
+
setting_sources : setting_source list option;
27
+
max_buffer_size : int option;
28
+
user : string option;
29
+
output_format : Structured_output.t option;
30
+
unknown : Unknown.t;
31
+
}
32
+
33
+
let empty =
34
+
{
35
+
allowed_tools = [];
36
+
disallowed_tools = [];
37
+
max_thinking_tokens = None;
38
+
system_prompt = None;
39
+
append_system_prompt = None;
40
+
permission_mode = None;
41
+
model = None;
42
+
continue_conversation = false;
43
+
resume = None;
44
+
max_turns = None;
45
+
permission_prompt_tool_name = None;
46
+
settings = None;
47
+
add_dirs = [];
48
+
max_budget_usd = None;
49
+
fallback_model = None;
50
+
setting_sources = None;
51
+
max_buffer_size = None;
52
+
user = None;
53
+
output_format = None;
54
+
unknown = Unknown.empty;
55
+
}
56
+
57
+
(** Accessor functions *)
58
+
let allowed_tools t = t.allowed_tools
59
+
let disallowed_tools t = t.disallowed_tools
60
+
let max_thinking_tokens t = t.max_thinking_tokens
61
+
let system_prompt t = t.system_prompt
62
+
let append_system_prompt t = t.append_system_prompt
63
+
let permission_mode t = t.permission_mode
64
+
let model t = t.model
65
+
let continue_conversation t = t.continue_conversation
66
+
let resume t = t.resume
67
+
let max_turns t = t.max_turns
68
+
let permission_prompt_tool_name t = t.permission_prompt_tool_name
69
+
let settings t = t.settings
70
+
let add_dirs t = t.add_dirs
71
+
let max_budget_usd t = t.max_budget_usd
72
+
let fallback_model t = t.fallback_model
73
+
let setting_sources t = t.setting_sources
74
+
let max_buffer_size t = t.max_buffer_size
75
+
let user t = t.user
76
+
let output_format t = t.output_format
77
+
let unknown t = t.unknown
78
+
79
+
(** Builder functions *)
80
+
let with_allowed_tools allowed_tools t = { t with allowed_tools }
81
+
let with_disallowed_tools disallowed_tools t = { t with disallowed_tools }
82
+
83
+
let with_max_thinking_tokens max_thinking_tokens t =
84
+
{ t with max_thinking_tokens = Some max_thinking_tokens }
85
+
86
+
let with_system_prompt system_prompt t =
87
+
{ t with system_prompt = Some system_prompt }
88
+
89
+
let with_append_system_prompt append_system_prompt t =
90
+
{ t with append_system_prompt = Some append_system_prompt }
91
+
92
+
let with_permission_mode permission_mode t =
93
+
{ t with permission_mode = Some permission_mode }
94
+
95
+
let with_model model t = { t with model = Some model }
96
+
97
+
let with_continue_conversation continue_conversation t =
98
+
{ t with continue_conversation }
99
+
100
+
let with_resume resume t = { t with resume = Some resume }
101
+
let with_max_turns max_turns t = { t with max_turns = Some max_turns }
102
+
103
+
let with_permission_prompt_tool_name permission_prompt_tool_name t =
104
+
{ t with permission_prompt_tool_name = Some permission_prompt_tool_name }
105
+
106
+
let with_settings settings t = { t with settings = Some settings }
107
+
let with_add_dirs add_dirs t = { t with add_dirs }
108
+
109
+
let with_max_budget_usd max_budget_usd t =
110
+
{ t with max_budget_usd = Some max_budget_usd }
111
+
112
+
let with_fallback_model fallback_model t =
113
+
{ t with fallback_model = Some fallback_model }
114
+
115
+
let with_setting_sources setting_sources t =
116
+
{ t with setting_sources = Some setting_sources }
117
+
118
+
let with_max_buffer_size max_buffer_size t =
119
+
{ t with max_buffer_size = Some max_buffer_size }
120
+
121
+
let with_user user t = { t with user = Some user }
122
+
123
+
let with_output_format output_format t =
124
+
{ t with output_format = Some output_format }
125
+
126
+
(** JSON codec *)
127
+
let jsont : t Jsont.t =
128
+
let make allowed_tools disallowed_tools max_thinking_tokens system_prompt
129
+
append_system_prompt permission_mode model continue_conversation resume
130
+
max_turns permission_prompt_tool_name settings add_dirs max_budget_usd
131
+
fallback_model setting_sources max_buffer_size user output_format unknown =
132
+
{
133
+
allowed_tools;
134
+
disallowed_tools;
135
+
max_thinking_tokens;
136
+
system_prompt;
137
+
append_system_prompt;
138
+
permission_mode;
139
+
model;
140
+
continue_conversation;
141
+
resume;
142
+
max_turns;
143
+
permission_prompt_tool_name;
144
+
settings;
145
+
add_dirs;
146
+
max_budget_usd;
147
+
fallback_model;
148
+
setting_sources;
149
+
max_buffer_size;
150
+
user;
151
+
output_format;
152
+
unknown;
153
+
}
154
+
in
155
+
Jsont.Object.(
156
+
map ~kind:"Options" make
157
+
|> mem "allowedTools" (Jsont.list Jsont.string) ~enc:allowed_tools
158
+
~dec_absent:[]
159
+
|> mem "disallowedTools" (Jsont.list Jsont.string) ~enc:disallowed_tools
160
+
~dec_absent:[]
161
+
|> opt_mem "maxThinkingTokens" Jsont.int ~enc:max_thinking_tokens
162
+
|> opt_mem "systemPrompt" Jsont.string ~enc:system_prompt
163
+
|> opt_mem "appendSystemPrompt" Jsont.string ~enc:append_system_prompt
164
+
|> opt_mem "permissionMode" Permissions.Mode.jsont ~enc:permission_mode
165
+
|> opt_mem "model" Model.jsont ~enc:model
166
+
|> mem "continueConversation" Jsont.bool ~enc:continue_conversation
167
+
~dec_absent:false
168
+
|> opt_mem "resume" Jsont.string ~enc:resume
169
+
|> opt_mem "maxTurns" Jsont.int ~enc:max_turns
170
+
|> opt_mem "permissionPromptToolName" Jsont.string
171
+
~enc:permission_prompt_tool_name
172
+
|> opt_mem "settings" Jsont.string ~enc:settings
173
+
|> mem "addDirs" (Jsont.list Jsont.string) ~enc:add_dirs ~dec_absent:[]
174
+
|> opt_mem "maxBudgetUsd" Jsont.number ~enc:max_budget_usd
175
+
|> opt_mem "fallbackModel" Model.jsont ~enc:fallback_model
176
+
|> opt_mem "settingSources" (Jsont.list setting_source_jsont)
177
+
~enc:setting_sources
178
+
|> opt_mem "maxBufferSize" Jsont.int ~enc:max_buffer_size
179
+
|> opt_mem "user" Jsont.string ~enc:user
180
+
|> opt_mem "outputFormat" Structured_output.jsont ~enc:output_format
181
+
|> keep_unknown Unknown.mems ~enc:unknown
182
+
|> finish)
+192
proto/options.mli
+192
proto/options.mli
···
1
+
(** Wire format for Claude configuration options.
2
+
3
+
This module provides the protocol-level wire format encoding/decoding for
4
+
configuration options used in JSON configuration files. It handles JSON
5
+
serialization and deserialization with proper field name mappings
6
+
(camelCase).
7
+
8
+
This is the protocol-level module without Eio types or logging. *)
9
+
10
+
(** {1 Setting Sources} *)
11
+
12
+
type setting_source =
13
+
| User (** User-level settings *)
14
+
| Project (** Project-level settings *)
15
+
| Local (** Local directory settings *)
16
+
(** The type of setting sources, indicating where configuration was loaded
17
+
from. *)
18
+
19
+
(** {1 Configuration Type} *)
20
+
21
+
type t
22
+
(** The type of configuration options.
23
+
24
+
This represents all configurable options for Claude interactions, encoded
25
+
in JSON format. *)
26
+
27
+
val jsont : t Jsont.t
28
+
(** [jsont] is the Jsont codec for configuration options.
29
+
30
+
Wire format uses camelCase field names:
31
+
- allowedTools (array of strings)
32
+
- disallowedTools (array of strings)
33
+
- maxThinkingTokens (int)
34
+
- systemPrompt (string)
35
+
- appendSystemPrompt (string)
36
+
- permissionMode (string via Permissions.Mode.jsont)
37
+
- model (string via Model.jsont)
38
+
- continueConversation (bool)
39
+
- resume (string)
40
+
- maxTurns (int)
41
+
- permissionPromptToolName (string)
42
+
- settings (string)
43
+
- addDirs (array of strings)
44
+
- maxBudgetUsd (float)
45
+
- fallbackModel (string via Model.jsont)
46
+
- settingSources (array of "user", "project", "local")
47
+
- maxBufferSize (int)
48
+
- user (string)
49
+
- outputFormat (object via Structured_output.jsont)
50
+
51
+
Unknown fields are preserved for forward compatibility. *)
52
+
53
+
val empty : t
54
+
(** [empty] is an empty configuration with all fields set to their default
55
+
values.
56
+
57
+
Default values:
58
+
- Lists default to empty
59
+
- [maxThinkingTokens] defaults to 8000
60
+
- [continueConversation] defaults to false
61
+
- All optional fields default to [None] *)
62
+
63
+
(** {1 Accessor Functions} *)
64
+
65
+
val allowed_tools : t -> string list
66
+
(** [allowed_tools t] returns the list of allowed tool names. Empty list means
67
+
all tools are allowed (unless explicitly disallowed). *)
68
+
69
+
val disallowed_tools : t -> string list
70
+
(** [disallowed_tools t] returns the list of disallowed tool names. *)
71
+
72
+
val max_thinking_tokens : t -> int option
73
+
(** [max_thinking_tokens t] returns the maximum number of tokens Claude can use
74
+
for internal thinking. *)
75
+
76
+
val system_prompt : t -> string option
77
+
(** [system_prompt t] returns the system prompt to use for Claude. *)
78
+
79
+
val append_system_prompt : t -> string option
80
+
(** [append_system_prompt t] returns additional text to append to the system
81
+
prompt. *)
82
+
83
+
val permission_mode : t -> Permissions.Mode.t option
84
+
(** [permission_mode t] returns the permission mode controlling how tool
85
+
invocations are authorized. *)
86
+
87
+
val model : t -> Model.t option
88
+
(** [model t] returns the Claude model to use for interactions. *)
89
+
90
+
val continue_conversation : t -> bool
91
+
(** [continue_conversation t] returns whether to continue from a previous
92
+
conversation. *)
93
+
94
+
val resume : t -> string option
95
+
(** [resume t] returns the session ID to resume from. *)
96
+
97
+
val max_turns : t -> int option
98
+
(** [max_turns t] returns the maximum number of conversation turns to allow. *)
99
+
100
+
val permission_prompt_tool_name : t -> string option
101
+
(** [permission_prompt_tool_name t] returns the tool name to use for permission
102
+
prompts. *)
103
+
104
+
val settings : t -> string option
105
+
(** [settings t] returns the path to the settings file. *)
106
+
107
+
val add_dirs : t -> string list
108
+
(** [add_dirs t] returns additional directories to include in the context. *)
109
+
110
+
val max_budget_usd : t -> float option
111
+
(** [max_budget_usd t] returns the maximum budget in USD for API calls. *)
112
+
113
+
val fallback_model : t -> Model.t option
114
+
(** [fallback_model t] returns the fallback model to use if the primary model
115
+
fails. *)
116
+
117
+
val setting_sources : t -> setting_source list option
118
+
(** [setting_sources t] returns the list of setting sources to load from. *)
119
+
120
+
val max_buffer_size : t -> int option
121
+
(** [max_buffer_size t] returns the maximum buffer size for I/O operations. *)
122
+
123
+
val user : t -> string option
124
+
(** [user t] returns the user identifier for the session. *)
125
+
126
+
val output_format : t -> Structured_output.t option
127
+
(** [output_format t] returns the structured output format configuration. *)
128
+
129
+
val unknown : t -> Unknown.t
130
+
(** [unknown t] returns the unknown fields preserved from JSON parsing. *)
131
+
132
+
(** {1 Builder Functions} *)
133
+
134
+
val with_allowed_tools : string list -> t -> t
135
+
(** [with_allowed_tools tools t] sets the allowed tools. *)
136
+
137
+
val with_disallowed_tools : string list -> t -> t
138
+
(** [with_disallowed_tools tools t] sets the disallowed tools. *)
139
+
140
+
val with_max_thinking_tokens : int -> t -> t
141
+
(** [with_max_thinking_tokens tokens t] sets the maximum thinking tokens. *)
142
+
143
+
val with_system_prompt : string -> t -> t
144
+
(** [with_system_prompt prompt t] sets the system prompt. *)
145
+
146
+
val with_append_system_prompt : string -> t -> t
147
+
(** [with_append_system_prompt prompt t] sets the text to append to the system
148
+
prompt. *)
149
+
150
+
val with_permission_mode : Permissions.Mode.t -> t -> t
151
+
(** [with_permission_mode mode t] sets the permission mode. *)
152
+
153
+
val with_model : Model.t -> t -> t
154
+
(** [with_model model t] sets the Claude model. *)
155
+
156
+
val with_continue_conversation : bool -> t -> t
157
+
(** [with_continue_conversation continue t] sets whether to continue
158
+
conversation. *)
159
+
160
+
val with_resume : string -> t -> t
161
+
(** [with_resume session_id t] sets the session ID to resume from. *)
162
+
163
+
val with_max_turns : int -> t -> t
164
+
(** [with_max_turns turns t] sets the maximum number of turns. *)
165
+
166
+
val with_permission_prompt_tool_name : string -> t -> t
167
+
(** [with_permission_prompt_tool_name tool t] sets the permission prompt tool
168
+
name. *)
169
+
170
+
val with_settings : string -> t -> t
171
+
(** [with_settings path t] sets the settings file path. *)
172
+
173
+
val with_add_dirs : string list -> t -> t
174
+
(** [with_add_dirs dirs t] sets the additional directories. *)
175
+
176
+
val with_max_budget_usd : float -> t -> t
177
+
(** [with_max_budget_usd budget t] sets the maximum budget. *)
178
+
179
+
val with_fallback_model : Model.t -> t -> t
180
+
(** [with_fallback_model model t] sets the fallback model. *)
181
+
182
+
val with_setting_sources : setting_source list -> t -> t
183
+
(** [with_setting_sources sources t] sets the setting sources. *)
184
+
185
+
val with_max_buffer_size : int -> t -> t
186
+
(** [with_max_buffer_size size t] sets the maximum buffer size. *)
187
+
188
+
val with_user : string -> t -> t
189
+
(** [with_user user t] sets the user identifier. *)
190
+
191
+
val with_output_format : Structured_output.t -> t -> t
192
+
(** [with_output_format format t] sets the structured output format. *)
+77
proto/outgoing.ml
+77
proto/outgoing.ml
···
1
+
(** Outgoing messages to Claude CLI.
2
+
3
+
This uses the Message.jsont for conversation messages and Control envelope
4
+
codecs for control messages. The top-level discriminator is the "type"
5
+
field. *)
6
+
7
+
type t =
8
+
| Message of Message.t
9
+
| Control_request of Control.request_envelope
10
+
| Control_response of Control.response_envelope
11
+
12
+
let jsont : t Jsont.t =
13
+
(* Message types use "user", "assistant", "system", "result" as type values.
14
+
Control uses "control_request" and "control_response".
15
+
16
+
We use case_mem for all types. For Message, we use Message.jsont which
17
+
already handles the inner "type" discrimination. *)
18
+
let case_control_request =
19
+
Jsont.Object.Case.map "control_request" Control.request_envelope_jsont
20
+
~dec:(fun v -> Control_request v)
21
+
in
22
+
let case_control_response =
23
+
Jsont.Object.Case.map "control_response" Control.response_envelope_jsont
24
+
~dec:(fun v -> Control_response v)
25
+
in
26
+
(* For messages, we need to handle all four message types *)
27
+
let case_user =
28
+
Jsont.Object.Case.map "user" Message.User.outgoing_jsont ~dec:(fun v ->
29
+
Message (Message.User v))
30
+
in
31
+
let case_assistant =
32
+
Jsont.Object.Case.map "assistant" Message.Assistant.jsont ~dec:(fun v ->
33
+
Message (Message.Assistant v))
34
+
in
35
+
let case_system =
36
+
Jsont.Object.Case.map "system" Message.System.jsont ~dec:(fun v ->
37
+
Message (Message.System v))
38
+
in
39
+
let case_result =
40
+
Jsont.Object.Case.map "result" Message.Result.jsont ~dec:(fun v ->
41
+
Message (Message.Result v))
42
+
in
43
+
let enc_case = function
44
+
| Control_request v -> Jsont.Object.Case.value case_control_request v
45
+
| Control_response v -> Jsont.Object.Case.value case_control_response v
46
+
| Message msg -> (
47
+
match msg with
48
+
| Message.User u -> Jsont.Object.Case.value case_user u
49
+
| Message.Assistant a -> Jsont.Object.Case.value case_assistant a
50
+
| Message.System s -> Jsont.Object.Case.value case_system s
51
+
| Message.Result r -> Jsont.Object.Case.value case_result r)
52
+
in
53
+
let cases =
54
+
Jsont.Object.Case.
55
+
[
56
+
make case_control_request;
57
+
make case_control_response;
58
+
make case_user;
59
+
make case_assistant;
60
+
make case_system;
61
+
make case_result;
62
+
]
63
+
in
64
+
Jsont.Object.map ~kind:"Outgoing" Fun.id
65
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
66
+
~tag_to_string:Fun.id ~tag_compare:String.compare
67
+
|> Jsont.Object.finish
68
+
69
+
let to_json t =
70
+
match Jsont.Json.encode jsont t with
71
+
| Ok json -> json
72
+
| Error e -> invalid_arg ("to_json: " ^ e)
73
+
74
+
let of_json json =
75
+
match Jsont.Json.decode jsont json with
76
+
| Ok v -> v
77
+
| Error e -> invalid_arg ("of_json: " ^ e)
+19
proto/outgoing.mli
+19
proto/outgoing.mli
···
1
+
(** Outgoing messages to the Claude CLI.
2
+
3
+
This module provides encoding for all message types that can be sent to the
4
+
Claude CLI. *)
5
+
6
+
type t =
7
+
| Message of Message.t
8
+
| Control_request of Control.request_envelope
9
+
| Control_response of Control.response_envelope
10
+
11
+
val jsont : t Jsont.t
12
+
(** Codec for outgoing messages. *)
13
+
14
+
val to_json : t -> Jsont.json
15
+
(** [to_json t] converts an outgoing message to JSON. *)
16
+
17
+
val of_json : Jsont.json -> t
18
+
(** [of_json json] parses an outgoing message from JSON.
19
+
@raise Invalid_argument if parsing fails. *)
+242
proto/permissions.ml
+242
proto/permissions.ml
···
1
+
(** Permission system wire format for Claude tool invocations.
2
+
3
+
This module provides the wire format encoding/decoding for permission types
4
+
used in the Claude protocol. It handles JSON serialization and
5
+
deserialization with proper field name mappings. *)
6
+
7
+
(** Permission modes *)
8
+
module Mode = struct
9
+
type t = Default | Accept_edits | Plan | Bypass_permissions
10
+
11
+
let to_string = function
12
+
| Default -> "default"
13
+
| Accept_edits -> "acceptEdits"
14
+
| Plan -> "plan"
15
+
| Bypass_permissions -> "bypassPermissions"
16
+
17
+
let of_string = function
18
+
| "default" -> Default
19
+
| "acceptEdits" -> Accept_edits
20
+
| "plan" -> Plan
21
+
| "bypassPermissions" -> Bypass_permissions
22
+
| s ->
23
+
raise
24
+
(Invalid_argument (Printf.sprintf "Mode.of_string: unknown mode %s" s))
25
+
26
+
let jsont : t Jsont.t =
27
+
Jsont.enum
28
+
[
29
+
("default", Default);
30
+
("acceptEdits", Accept_edits);
31
+
("plan", Plan);
32
+
("bypassPermissions", Bypass_permissions);
33
+
]
34
+
end
35
+
36
+
(** Permission behaviors *)
37
+
module Behavior = struct
38
+
type t = Allow | Deny | Ask
39
+
40
+
let to_string = function Allow -> "allow" | Deny -> "deny" | Ask -> "ask"
41
+
42
+
let of_string = function
43
+
| "allow" -> Allow
44
+
| "deny" -> Deny
45
+
| "ask" -> Ask
46
+
| s ->
47
+
raise
48
+
(Invalid_argument
49
+
(Printf.sprintf "Behavior.of_string: unknown behavior %s" s))
50
+
51
+
let jsont : t Jsont.t =
52
+
Jsont.enum [ ("allow", Allow); ("deny", Deny); ("ask", Ask) ]
53
+
end
54
+
55
+
(** Permission rules *)
56
+
module Rule = struct
57
+
type t = {
58
+
tool_name : string;
59
+
rule_content : string option;
60
+
unknown : Unknown.t;
61
+
}
62
+
63
+
let create ~tool_name ?rule_content ?(unknown = Unknown.empty) () =
64
+
{ tool_name; rule_content; unknown }
65
+
66
+
let tool_name t = t.tool_name
67
+
let rule_content t = t.rule_content
68
+
let unknown t = t.unknown
69
+
70
+
let jsont : t Jsont.t =
71
+
let make tool_name rule_content unknown =
72
+
{ tool_name; rule_content; unknown }
73
+
in
74
+
Jsont.Object.map ~kind:"Rule" make
75
+
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:tool_name
76
+
|> Jsont.Object.opt_mem "rule_content" Jsont.string ~enc:rule_content
77
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
78
+
|> Jsont.Object.finish
79
+
end
80
+
81
+
(** Permission updates *)
82
+
module Update = struct
83
+
type destination =
84
+
| User_settings
85
+
| Project_settings
86
+
| Local_settings
87
+
| Session
88
+
89
+
let destination_jsont : destination Jsont.t =
90
+
Jsont.enum
91
+
[
92
+
("userSettings", User_settings);
93
+
("projectSettings", Project_settings);
94
+
("localSettings", Local_settings);
95
+
("session", Session);
96
+
]
97
+
98
+
type update_type =
99
+
| Add_rules
100
+
| Replace_rules
101
+
| Remove_rules
102
+
| Set_mode
103
+
| Add_directories
104
+
| Remove_directories
105
+
106
+
let update_type_jsont : update_type Jsont.t =
107
+
Jsont.enum
108
+
[
109
+
("addRules", Add_rules);
110
+
("replaceRules", Replace_rules);
111
+
("removeRules", Remove_rules);
112
+
("setMode", Set_mode);
113
+
("addDirectories", Add_directories);
114
+
("removeDirectories", Remove_directories);
115
+
]
116
+
117
+
type t = {
118
+
update_type : update_type;
119
+
rules : Rule.t list option;
120
+
behavior : Behavior.t option;
121
+
mode : Mode.t option;
122
+
directories : string list option;
123
+
destination : destination option;
124
+
unknown : Unknown.t;
125
+
}
126
+
127
+
let create ~update_type ?rules ?behavior ?mode ?directories ?destination
128
+
?(unknown = Unknown.empty) () =
129
+
{ update_type; rules; behavior; mode; directories; destination; unknown }
130
+
131
+
let update_type t = t.update_type
132
+
let rules t = t.rules
133
+
let behavior t = t.behavior
134
+
let mode t = t.mode
135
+
let directories t = t.directories
136
+
let destination t = t.destination
137
+
let unknown t = t.unknown
138
+
139
+
let jsont : t Jsont.t =
140
+
let make update_type rules behavior mode directories destination unknown =
141
+
{ update_type; rules; behavior; mode; directories; destination; unknown }
142
+
in
143
+
Jsont.Object.map ~kind:"Update" make
144
+
|> Jsont.Object.mem "type" update_type_jsont ~enc:update_type
145
+
|> Jsont.Object.opt_mem "rules" (Jsont.list Rule.jsont) ~enc:rules
146
+
|> Jsont.Object.opt_mem "behavior" Behavior.jsont ~enc:behavior
147
+
|> Jsont.Object.opt_mem "mode" Mode.jsont ~enc:mode
148
+
|> Jsont.Object.opt_mem "directories" (Jsont.list Jsont.string)
149
+
~enc:directories
150
+
|> Jsont.Object.opt_mem "destination" destination_jsont ~enc:destination
151
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
152
+
|> Jsont.Object.finish
153
+
end
154
+
155
+
(** Permission context for callbacks *)
156
+
module Context = struct
157
+
type t = { suggestions : Update.t list; unknown : Unknown.t }
158
+
159
+
let create ?(suggestions = []) ?(unknown = Unknown.empty) () =
160
+
{ suggestions; unknown }
161
+
162
+
let suggestions t = t.suggestions
163
+
let unknown t = t.unknown
164
+
165
+
let jsont : t Jsont.t =
166
+
let make suggestions unknown = { suggestions; unknown } in
167
+
Jsont.Object.map ~kind:"Context" make
168
+
|> Jsont.Object.mem "suggestions" (Jsont.list Update.jsont) ~enc:suggestions
169
+
~dec_absent:[]
170
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
171
+
|> Jsont.Object.finish
172
+
end
173
+
174
+
(** Permission results *)
175
+
module Result = struct
176
+
type t =
177
+
| Allow of {
178
+
updated_input : Jsont.json option;
179
+
updated_permissions : Update.t list option;
180
+
unknown : Unknown.t;
181
+
}
182
+
| Deny of { message : string; interrupt : bool; unknown : Unknown.t }
183
+
184
+
let allow ?updated_input ?updated_permissions ?(unknown = Unknown.empty) () =
185
+
Allow { updated_input; updated_permissions; unknown }
186
+
187
+
let deny ~message ~interrupt ?(unknown = Unknown.empty) () =
188
+
Deny { message; interrupt; unknown }
189
+
190
+
let jsont : t Jsont.t =
191
+
let allow_record =
192
+
let make updated_input updated_permissions unknown =
193
+
Allow { updated_input; updated_permissions; unknown }
194
+
in
195
+
Jsont.Object.map ~kind:"AllowRecord" make
196
+
|> Jsont.Object.opt_mem "updated_input" Jsont.json ~enc:(function
197
+
| Allow { updated_input; _ } -> updated_input
198
+
| _ -> None)
199
+
|> Jsont.Object.opt_mem "updated_permissions" (Jsont.list Update.jsont)
200
+
~enc:(function
201
+
| Allow { updated_permissions; _ } -> updated_permissions
202
+
| _ -> None)
203
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(function
204
+
| Allow { unknown; _ } -> unknown
205
+
| _ -> Unknown.empty)
206
+
|> Jsont.Object.finish
207
+
in
208
+
let deny_record =
209
+
let make message interrupt unknown =
210
+
Deny { message; interrupt; unknown }
211
+
in
212
+
Jsont.Object.map ~kind:"DenyRecord" make
213
+
|> Jsont.Object.mem "message" Jsont.string ~enc:(function
214
+
| Deny { message; _ } -> message
215
+
| _ -> "")
216
+
|> Jsont.Object.mem "interrupt" Jsont.bool ~enc:(function
217
+
| Deny { interrupt; _ } -> interrupt
218
+
| _ -> false)
219
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(function
220
+
| Deny { unknown; _ } -> unknown
221
+
| _ -> Unknown.empty)
222
+
|> Jsont.Object.finish
223
+
in
224
+
let case_allow =
225
+
Jsont.Object.Case.map "allow" allow_record ~dec:(fun v -> v)
226
+
in
227
+
let case_deny =
228
+
Jsont.Object.Case.map "deny" deny_record ~dec:(fun v -> v)
229
+
in
230
+
231
+
let enc_case = function
232
+
| Allow _ as v -> Jsont.Object.Case.value case_allow v
233
+
| Deny _ as v -> Jsont.Object.Case.value case_deny v
234
+
in
235
+
236
+
let cases = Jsont.Object.Case.[ make case_allow; make case_deny ] in
237
+
238
+
Jsont.Object.map ~kind:"Result" Fun.id
239
+
|> Jsont.Object.case_mem "behavior" Jsont.string ~enc:Fun.id ~enc_case cases
240
+
~tag_to_string:Fun.id ~tag_compare:String.compare
241
+
|> Jsont.Object.finish
242
+
end
+222
proto/permissions.mli
+222
proto/permissions.mli
···
1
+
(** Permission system wire format for Claude tool invocations.
2
+
3
+
This module provides the wire format encoding/decoding for permission types
4
+
used in the Claude protocol. It handles JSON serialization and
5
+
deserialization with proper field name mappings. *)
6
+
7
+
(** {1 Permission Modes} *)
8
+
9
+
module Mode : sig
10
+
(** Permission modes control the overall behavior of the permission system. *)
11
+
12
+
type t =
13
+
| Default (** Standard permission mode with normal checks *)
14
+
| Accept_edits (** Automatically accept file edits *)
15
+
| Plan (** Planning mode with restricted execution *)
16
+
| Bypass_permissions (** Bypass all permission checks *)
17
+
(** The type of permission modes. *)
18
+
19
+
val jsont : t Jsont.t
20
+
(** [jsont] is the Jsont codec for permission modes. Wire format uses
21
+
camelCase: "default", "acceptEdits", "plan", "bypassPermissions". *)
22
+
23
+
val to_string : t -> string
24
+
(** [to_string t] converts a mode to its wire format string representation. *)
25
+
26
+
val of_string : string -> t
27
+
(** [of_string s] parses a mode from its wire format string representation.
28
+
@raise Invalid_argument if the string is not a valid mode. *)
29
+
end
30
+
31
+
(** {1 Permission Behaviors} *)
32
+
33
+
module Behavior : sig
34
+
(** Behaviors determine how permission requests are handled. *)
35
+
36
+
type t =
37
+
| Allow (** Allow the operation *)
38
+
| Deny (** Deny the operation *)
39
+
| Ask (** Ask the user for permission *)
40
+
(** The type of permission behaviors. *)
41
+
42
+
val jsont : t Jsont.t
43
+
(** [jsont] is the Jsont codec for permission behaviors. Wire format uses
44
+
lowercase: "allow", "deny", "ask". *)
45
+
46
+
val to_string : t -> string
47
+
(** [to_string t] converts a behavior to its wire format string
48
+
representation. *)
49
+
50
+
val of_string : string -> t
51
+
(** [of_string s] parses a behavior from its wire format string
52
+
representation.
53
+
@raise Invalid_argument if the string is not a valid behavior. *)
54
+
end
55
+
56
+
(** {1 Permission Rules} *)
57
+
58
+
module Rule : sig
59
+
(** Rules define specific permissions for tools. *)
60
+
61
+
type t
62
+
(** The type of permission rules. *)
63
+
64
+
val jsont : t Jsont.t
65
+
(** [jsont] is the Jsont codec for permission rules. Preserves unknown fields
66
+
for forward compatibility. *)
67
+
68
+
val create :
69
+
tool_name:string -> ?rule_content:string -> ?unknown:Unknown.t -> unit -> t
70
+
(** [create ~tool_name ?rule_content ?unknown ()] creates a new rule.
71
+
@param tool_name The name of the tool this rule applies to
72
+
@param rule_content Optional rule specification or pattern
73
+
@param unknown Optional unknown fields to preserve *)
74
+
75
+
val tool_name : t -> string
76
+
(** [tool_name t] returns the tool name. *)
77
+
78
+
val rule_content : t -> string option
79
+
(** [rule_content t] returns the optional rule content. *)
80
+
81
+
val unknown : t -> Unknown.t
82
+
(** [unknown t] returns the unknown fields. *)
83
+
end
84
+
85
+
(** {1 Permission Updates} *)
86
+
87
+
module Update : sig
88
+
(** Updates modify permission settings. *)
89
+
90
+
type destination =
91
+
| User_settings (** Apply to user settings *)
92
+
| Project_settings (** Apply to project settings *)
93
+
| Local_settings (** Apply to local settings *)
94
+
| Session (** Apply to current session only *)
95
+
(** The destination for permission updates. *)
96
+
97
+
type update_type =
98
+
| Add_rules (** Add new rules *)
99
+
| Replace_rules (** Replace existing rules *)
100
+
| Remove_rules (** Remove rules *)
101
+
| Set_mode (** Set permission mode *)
102
+
| Add_directories (** Add allowed directories *)
103
+
| Remove_directories (** Remove allowed directories *)
104
+
(** The type of permission update. *)
105
+
106
+
type t
107
+
(** The type of permission updates. *)
108
+
109
+
val jsont : t Jsont.t
110
+
(** [jsont] is the Jsont codec for permission updates. Wire format uses
111
+
camelCase for destination ("userSettings", "projectSettings",
112
+
"localSettings", "session") and update_type ("addRules", "replaceRules",
113
+
"removeRules", "setMode", "addDirectories", "removeDirectories"). *)
114
+
115
+
val create :
116
+
update_type:update_type ->
117
+
?rules:Rule.t list ->
118
+
?behavior:Behavior.t ->
119
+
?mode:Mode.t ->
120
+
?directories:string list ->
121
+
?destination:destination ->
122
+
?unknown:Unknown.t ->
123
+
unit ->
124
+
t
125
+
(** [create ~update_type ?rules ?behavior ?mode ?directories ?destination
126
+
?unknown ()] creates a new permission update.
127
+
@param update_type The type of update to perform
128
+
@param rules Optional list of rules to add/remove/replace
129
+
@param behavior Optional behavior to set
130
+
@param mode Optional permission mode to set
131
+
@param directories Optional directories to add/remove
132
+
@param destination Optional destination for the update
133
+
@param unknown Optional unknown fields to preserve *)
134
+
135
+
val update_type : t -> update_type
136
+
(** [update_type t] returns the update type. *)
137
+
138
+
val rules : t -> Rule.t list option
139
+
(** [rules t] returns the optional list of rules. *)
140
+
141
+
val behavior : t -> Behavior.t option
142
+
(** [behavior t] returns the optional behavior. *)
143
+
144
+
val mode : t -> Mode.t option
145
+
(** [mode t] returns the optional mode. *)
146
+
147
+
val directories : t -> string list option
148
+
(** [directories t] returns the optional list of directories. *)
149
+
150
+
val destination : t -> destination option
151
+
(** [destination t] returns the optional destination. *)
152
+
153
+
val unknown : t -> Unknown.t
154
+
(** [unknown t] returns the unknown fields. *)
155
+
end
156
+
157
+
(** {1 Permission Context} *)
158
+
159
+
module Context : sig
160
+
(** Context provided to permission callbacks. *)
161
+
162
+
type t
163
+
(** The type of permission context. *)
164
+
165
+
val jsont : t Jsont.t
166
+
(** [jsont] is the Jsont codec for permission context. Preserves unknown
167
+
fields for forward compatibility. *)
168
+
169
+
val create : ?suggestions:Update.t list -> ?unknown:Unknown.t -> unit -> t
170
+
(** [create ?suggestions ?unknown ()] creates a new context.
171
+
@param suggestions Optional list of suggested permission updates
172
+
@param unknown Optional unknown fields to preserve *)
173
+
174
+
val suggestions : t -> Update.t list
175
+
(** [suggestions t] returns the list of suggested updates. *)
176
+
177
+
val unknown : t -> Unknown.t
178
+
(** [unknown t] returns the unknown fields. *)
179
+
end
180
+
181
+
(** {1 Permission Results} *)
182
+
183
+
module Result : sig
184
+
(** Results of permission checks. *)
185
+
186
+
type t =
187
+
| Allow of {
188
+
updated_input : Jsont.json option; (** Modified tool input *)
189
+
updated_permissions : Update.t list option;
190
+
(** Permission updates to apply *)
191
+
unknown : Unknown.t; (** Unknown fields *)
192
+
}
193
+
| Deny of {
194
+
message : string; (** Reason for denial *)
195
+
interrupt : bool; (** Whether to interrupt execution *)
196
+
unknown : Unknown.t; (** Unknown fields *)
197
+
}
198
+
(** The type of permission results. Wire format uses a discriminated union
199
+
with "behavior" field set to "allow" or "deny". *)
200
+
201
+
val jsont : t Jsont.t
202
+
(** [jsont] is the Jsont codec for permission results. Preserves unknown
203
+
fields for forward compatibility. *)
204
+
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.
213
+
@param updated_input Optional modified tool input
214
+
@param updated_permissions Optional permission updates to apply
215
+
@param unknown Optional unknown fields to preserve *)
216
+
217
+
val deny : message:string -> interrupt:bool -> ?unknown:Unknown.t -> unit -> t
218
+
(** [deny ~message ~interrupt ?unknown ()] creates a deny result.
219
+
@param message The reason for denying permission
220
+
@param interrupt Whether to interrupt further execution
221
+
@param unknown Optional unknown fields to preserve *)
222
+
end
+12
proto/structured_output.ml
+12
proto/structured_output.ml
···
1
+
(** Structured output wire format implementation. *)
2
+
3
+
type t = { json_schema : Jsont.json }
4
+
5
+
let of_json_schema schema = { json_schema = schema }
6
+
let to_json_schema t = t.json_schema
7
+
8
+
(* Codec for serializing structured output format to wire protocol *)
9
+
let jsont : t Jsont.t =
10
+
Jsont.Object.map ~kind:"StructuredOutput" (fun json_schema -> { json_schema })
11
+
|> Jsont.Object.mem "jsonSchema" Jsont.json ~enc:(fun t -> t.json_schema)
12
+
|> Jsont.Object.finish
+61
proto/structured_output.mli
+61
proto/structured_output.mli
···
1
+
(** Structured output configuration using JSON Schema.
2
+
3
+
This module provides the wire format types for structured output support,
4
+
allowing specification of expected output formats using JSON schemas. When a
5
+
structured output format is configured, Claude will return its response in
6
+
the specified JSON format, validated against the provided schema.
7
+
8
+
This is the protocol-level module. For the high-level API with logging and
9
+
additional features, see {!Claudeio.Structured_output}. *)
10
+
11
+
(** {1 Output Format Configuration} *)
12
+
13
+
type t
14
+
(** The type of structured output format configurations.
15
+
16
+
This wraps a JSON Schema that specifies the expected output format. *)
17
+
18
+
val of_json_schema : Jsont.json -> t
19
+
(** [of_json_schema schema] creates an output format from a JSON Schema.
20
+
21
+
The schema should be a valid JSON Schema Draft 7 as a {!Jsont.json} value.
22
+
23
+
Example:
24
+
{[
25
+
let meta = Jsont.Meta.none in
26
+
let schema =
27
+
Jsont.Object
28
+
( [
29
+
(("type", meta), Jsont.String ("object", meta));
30
+
( ("properties", meta),
31
+
Jsont.Object
32
+
( [
33
+
( ("name", meta),
34
+
Jsont.Object
35
+
([ (("type", meta), Jsont.String ("string", meta)) ], meta)
36
+
);
37
+
( ("age", meta),
38
+
Jsont.Object
39
+
([ (("type", meta), Jsont.String ("integer", meta)) ], meta)
40
+
);
41
+
],
42
+
meta ) );
43
+
( ("required", meta),
44
+
Jsont.Array
45
+
([ Jsont.String ("name", meta); Jsont.String ("age", meta) ], meta)
46
+
);
47
+
],
48
+
meta )
49
+
in
50
+
51
+
let format = Structured_output.of_json_schema schema
52
+
]} *)
53
+
54
+
val to_json_schema : t -> Jsont.json
55
+
(** [to_json_schema t] extracts the JSON Schema from the output format. *)
56
+
57
+
val jsont : t Jsont.t
58
+
(** Codec for structured output format.
59
+
60
+
Encodes/decodes the structured output configuration to/from the wire format
61
+
JSON representation used by the Claude CLI protocol. *)
+57
proto/unknown.ml
+57
proto/unknown.ml
···
1
+
(** Unknown fields for preserving extra JSON object members during
2
+
round-tripping.
3
+
4
+
This module provides an opaque type for storing unknown JSON fields as an
5
+
association list. This is useful for preserving fields that are not part of
6
+
the defined schema but should be maintained when reading and writing JSON.
7
+
*)
8
+
9
+
type t = (string * Jsont.json) list
10
+
11
+
let empty = []
12
+
let is_empty = function [] -> true | _ -> false
13
+
let of_assoc x = x
14
+
let to_assoc x = x
15
+
16
+
let jsont =
17
+
let open Jsont in
18
+
let dec obj =
19
+
match obj with
20
+
| Object (fields, _) ->
21
+
(* Convert from Jsont.mem list (name * json) to (string * json) list *)
22
+
List.map (fun ((name, _meta), json) -> (name, json)) fields
23
+
| _ -> invalid_arg "Expected object"
24
+
in
25
+
let enc fields =
26
+
(* Convert from (string * json) list to Jsont.mem list *)
27
+
let mems =
28
+
List.map (fun (name, json) -> ((name, Meta.none), json)) fields
29
+
in
30
+
Object (mems, Meta.none)
31
+
in
32
+
map ~dec ~enc json
33
+
34
+
(** Mems codec for use with Jsont.Object.keep_unknown.
35
+
36
+
This provides a custom mems codec that converts between our (string *
37
+
Jsont.json) list representation and the Jsont.mem list representation
38
+
used by keep_unknown. *)
39
+
let mems : (t, Jsont.json, Jsont.mem list) Jsont.Object.Mems.map =
40
+
let open Jsont in
41
+
(* The decoder builds up a mem list (the third type parameter) and
42
+
dec_finish converts it to our type t *)
43
+
let dec_empty () = [] in
44
+
let dec_add meta name json acc = ((name, meta), json) :: acc in
45
+
let dec_finish _meta mems =
46
+
(* Convert from mem list to (string * json) list *)
47
+
List.rev_map (fun ((name, _meta), json) -> (name, json)) mems
48
+
in
49
+
let enc =
50
+
{
51
+
Object.Mems.enc = (fun k fields acc ->
52
+
List.fold_left
53
+
(fun acc (name, json) -> k Meta.none name json acc)
54
+
acc fields);
55
+
}
56
+
in
57
+
Object.Mems.map ~kind:"Unknown" ~dec_empty ~dec_add ~dec_finish ~enc Jsont.json
+29
proto/unknown.mli
+29
proto/unknown.mli
···
1
+
(** Unknown fields for preserving extra JSON object members during
2
+
round-tripping.
3
+
4
+
This module provides an opaque type for storing unknown JSON fields as an
5
+
association list. This is useful for preserving fields that are not part of
6
+
the defined schema but should be maintained when reading and writing JSON.
7
+
*)
8
+
9
+
type t
10
+
(** The opaque type of unknown fields, stored as an association list of field
11
+
names to JSON values. *)
12
+
13
+
val empty : t
14
+
(** [empty] is an empty set of unknown fields. *)
15
+
16
+
val is_empty : t -> bool
17
+
(** [is_empty t] returns [true] if there are no unknown fields stored in [t]. *)
18
+
19
+
val of_assoc : (string * Jsont.json) list -> t
20
+
(** [of_assoc assoc] creates unknown fields from an association list. *)
21
+
22
+
val to_assoc : t -> (string * Jsont.json) list
23
+
(** [to_assoc t] returns the association list of unknown fields. *)
24
+
25
+
val jsont : t Jsont.t
26
+
(** [jsont] is a codec for encoding and decoding unknown fields to/from JSON. *)
27
+
28
+
val mems : (t, Jsont.json, Jsont.mem list) Jsont.Object.Mems.map
29
+
(** [mems] is a mems codec for use with [Jsont.Object.keep_unknown]. *)
+19
-36
test/advanced_config_demo.ml
+19
-36
test/advanced_config_demo.ml
···
23
23
let ci_cd_config () =
24
24
Options.default |> Options.with_no_settings (* Disable all settings loading *)
25
25
|> Options.with_max_budget_usd 0.50 (* 50 cent limit per run *)
26
-
|> Options.with_fallback_model_string "claude-haiku-4" (* Fast fallback *)
27
-
|> Options.with_model_string "claude-sonnet-4-5"
26
+
|> Options.with_fallback_model (Claude.Proto.Model.of_string "claude-haiku-4") (* Fast fallback *)
27
+
|> Options.with_model (Claude.Proto.Model.of_string "claude-sonnet-4-5")
28
28
|> Options.with_permission_mode Permissions.Mode.Bypass_permissions
29
29
30
30
(* Example 2: Production Configuration with Fallback
···
34
34
*)
35
35
let production_config () =
36
36
Options.default
37
-
|> Options.with_model_string "claude-sonnet-4-5"
38
-
|> Options.with_fallback_model_string "claude-sonnet-3-5"
37
+
|> Options.with_model (Claude.Proto.Model.of_string "claude-sonnet-4-5")
38
+
|> Options.with_fallback_model (Claude.Proto.Model.of_string "claude-sonnet-3-5")
39
39
|> Options.with_max_budget_usd 10.0 (* $10 limit *)
40
40
|> Options.with_max_buffer_size 5_000_000 (* 5MB buffer for large outputs *)
41
41
···
45
45
*)
46
46
let dev_config () =
47
47
Options.default
48
-
|> Options.with_setting_sources [ Options.User; Options.Project ]
48
+
(* Note: Settings are loaded by default from user/project/local files *)
49
49
|> Options.with_max_budget_usd 1.0 (* $1 limit for dev testing *)
50
-
|> Options.with_fallback_model_string "claude-haiku-4"
50
+
|> Options.with_fallback_model (Claude.Proto.Model.of_string "claude-haiku-4")
51
51
52
52
(* Example 4: Isolated Test Configuration
53
53
···
56
56
let test_config () =
57
57
Options.default |> Options.with_no_settings
58
58
|> Options.with_max_budget_usd 0.10 (* 10 cent limit per test *)
59
-
|> Options.with_model_string "claude-haiku-4" (* Fast, cheap model *)
59
+
|> Options.with_model (Claude.Proto.Model.of_string "claude-haiku-4") (* Fast, cheap model *)
60
60
|> Options.with_permission_mode Permissions.Mode.Bypass_permissions
61
61
|> Options.with_max_buffer_size 1_000_000 (* 1MB buffer *)
62
62
···
67
67
let _large_output_config () =
68
68
Options.default
69
69
|> Options.with_max_buffer_size 10_000_000 (* 10MB buffer *)
70
-
|> Options.with_model_string "claude-sonnet-4-5"
70
+
|> Options.with_model (Claude.Proto.Model.of_string "claude-sonnet-4-5")
71
71
72
72
(* Helper to run a query with a specific configuration *)
73
73
let run_query ~sw process_mgr config prompt =
···
77
77
| None -> print_endline "Budget limit: None");
78
78
(match Options.fallback_model config with
79
79
| Some model ->
80
-
Printf.printf "Fallback model: %s\n" (Claude.Model.to_string model)
80
+
Printf.printf "Fallback model: %s\n" (Claude.Proto.Model.to_string model)
81
81
| None -> print_endline "Fallback model: None");
82
-
(match Options.setting_sources config with
83
-
| Some [] -> print_endline "Settings: Isolated (no settings loaded)"
84
-
| Some sources ->
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
94
-
Printf.printf "Settings: %s\n" source_str
95
-
| None -> print_endline "Settings: Default");
82
+
(* Settings configuration display removed - API doesn't expose setting_sources *)
83
+
print_endline "Settings: Default (user/project/local files)";
96
84
(match Options.max_buffer_size config with
97
85
| Some size -> Printf.printf "Buffer size: %d bytes\n" size
98
86
| None -> print_endline "Buffer size: Default (1MB)");
···
100
88
print_endline "\n=== Running Query ===";
101
89
let client = Client.create ~options:config ~sw ~process_mgr () in
102
90
Client.query client prompt;
103
-
let messages = Client.receive client in
91
+
let responses = Client.receive client in
104
92
105
93
Seq.iter
106
94
(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 ->
95
+
| Response.Text text ->
96
+
Printf.printf "Response: %s\n" (Response.Text.content text)
97
+
| Response.Complete result ->
115
98
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
99
+
Printf.printf "Duration: %dms\n" (Response.Complete.duration_ms result);
100
+
(match Response.Complete.total_cost_usd result with
118
101
| Some cost -> Printf.printf "Cost: $%.4f\n" cost
119
102
| None -> ());
120
-
Printf.printf "Turns: %d\n" (Message.Result.num_turns result)
103
+
Printf.printf "Turns: %d\n" (Response.Complete.num_turns result)
121
104
| _ -> ())
122
-
messages
105
+
responses
123
106
124
107
let main () =
125
108
log_setup ();
+27
-38
test/camel_jokes.ml
+27
-38
test/camel_jokes.ml
···
6
6
7
7
let process_claude_response client name =
8
8
Log.info (fun m -> m "=== %s's Response ===" name);
9
-
let messages = Claude.Client.receive_all client in
9
+
let responses = Claude.Client.receive_all client in
10
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);
11
+
(fun resp ->
12
+
match resp with
13
+
| Claude.Response.Text t ->
14
+
let text = Claude.Response.Text.content t in
15
+
Log.app (fun m -> m "%s: %s" name text)
16
+
| Claude.Response.Tool_use t ->
17
+
Log.debug (fun m ->
18
+
m "%s using tool: %s" name (Claude.Response.Tool_use.name t))
19
+
| Claude.Response.Thinking t ->
29
20
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 -> ());
21
+
m "%s thinking: %s" name (Claude.Response.Thinking.content t))
22
+
| Claude.Response.Complete c ->
23
+
(if Claude.Response.Complete.total_cost_usd c <> None then
24
+
let cost = Option.get (Claude.Response.Complete.total_cost_usd c) in
25
+
Log.info (fun m -> m "%s's joke cost: $%.6f" name cost));
39
26
Log.debug (fun m ->
40
27
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 *)
28
+
(Claude.Response.Complete.session_id c)
29
+
(Claude.Response.Complete.duration_ms c))
30
+
| Claude.Response.Error e ->
31
+
Log.err (fun m -> m "Error from %s: %s" name (Claude.Response.Error.message e))
32
+
| Claude.Response.Init _ ->
33
+
(* Init messages are already logged by the library *)
45
34
()
46
-
| Claude.Message.User _ ->
47
-
(* User messages are already logged by the library *)
35
+
| Claude.Response.Tool_result _ ->
36
+
(* Tool results are user messages, skip *)
48
37
())
49
-
messages
38
+
responses
50
39
51
40
let run_claude ~sw ~env name prompt =
52
41
Log.info (fun m -> m "šŖ Starting %s..." name);
53
42
let options =
54
-
Claude.Options.create
55
-
~model:(Claude.Model.of_string "sonnet")
56
-
~allowed_tools:[] ()
43
+
Claude.Options.default
44
+
|> Claude.Options.with_model (Claude.Model.of_string "sonnet")
45
+
|> Claude.Options.with_allowed_tools []
57
46
in
58
47
59
48
let client =
+25
-30
test/discovery_demo.ml
+25
-30
test/discovery_demo.ml
···
6
6
module Log = (val Logs.src_log src : Logs.LOG)
7
7
8
8
let process_response client =
9
-
let messages = Claude.Client.receive_all client in
9
+
let responses = Claude.Client.receive_all client in
10
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 -> ())
11
+
(fun resp ->
12
+
match resp with
13
+
| Claude.Response.Text text ->
14
+
let content = Claude.Response.Text.content text in
15
+
Log.app (fun m ->
16
+
m "Claude: %s"
17
+
(if String.length content > 100 then
18
+
String.sub content 0 100 ^ "..."
19
+
else content))
20
+
| Claude.Response.Tool_use t ->
21
+
Log.info (fun m ->
22
+
m "Tool use: %s" (Claude.Response.Tool_use.name t))
23
+
| Claude.Response.Error err ->
24
+
Log.err (fun m -> m "Error: %s" (Claude.Response.Error.message err))
25
+
| Claude.Response.Complete result ->
26
+
(match Claude.Response.Complete.total_cost_usd result with
27
+
| Some cost -> Log.info (fun m -> m "Cost: $%.6f" cost)
28
+
| None -> ())
35
29
| _ -> ())
36
-
messages
30
+
responses
37
31
38
32
let run_discovery ~sw ~env =
39
33
Log.app (fun m -> m "š Permission Discovery Demo");
···
42
36
43
37
(* Create client with discovery mode *)
44
38
let options =
45
-
Claude.Options.create ~model:(Claude.Model.of_string "sonnet") ()
39
+
Claude.Options.default
40
+
|> Claude.Options.with_model (Claude.Proto.Model.of_string "sonnet")
46
41
in
47
42
let client =
48
-
Claude.Client.discover_permissions
49
-
(Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr ())
43
+
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr ()
50
44
in
45
+
Claude.Client.enable_permission_discovery client;
51
46
52
47
(* Send a prompt that will need permissions *)
53
48
Log.app (fun m -> m "Asking Claude to read a secret file...");
···
57
52
process_response client;
58
53
59
54
(* Check what permissions were requested *)
60
-
let permissions = Claude.Client.get_discovered_permissions client in
55
+
let permissions = Claude.Client.discovered_permissions client in
61
56
if permissions = [] then
62
57
Log.app (fun m ->
63
58
m
+14
-25
test/dynamic_control_demo.ml
+14
-25
test/dynamic_control_demo.ml
···
18
18
traceln "1. Initial query with default model";
19
19
Client.query client "What model are you?";
20
20
21
-
(* Consume initial messages *)
22
-
let messages = Client.receive_all client in
21
+
(* Consume initial responses *)
22
+
let responses = Client.receive_all client in
23
23
List.iter
24
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)
25
+
| Response.Text text ->
26
+
traceln "Assistant: %s" (Response.Text.content text)
32
27
| _ -> ())
33
-
messages;
28
+
responses;
34
29
35
30
traceln "\n2. Getting server info...";
36
31
(try
37
32
let info = Client.get_server_info client in
38
-
traceln "Server version: %s" (Sdk_control.Server_info.version info);
33
+
traceln "Server version: %s" (Claude.Server_info.version info);
39
34
traceln "Capabilities: [%s]"
40
-
(String.concat ", " (Sdk_control.Server_info.capabilities info));
35
+
(String.concat ", " (Claude.Server_info.capabilities info));
41
36
traceln "Commands: [%s]"
42
-
(String.concat ", " (Sdk_control.Server_info.commands info));
37
+
(String.concat ", " (Claude.Server_info.commands info));
43
38
traceln "Output styles: [%s]"
44
-
(String.concat ", " (Sdk_control.Server_info.output_styles info))
39
+
(String.concat ", " (Claude.Server_info.output_styles info))
45
40
with
46
41
| Failure msg -> traceln "Failed to get server info: %s" msg
47
42
| exn -> traceln "Error getting server info: %s" (Printexc.to_string exn));
48
43
49
44
traceln "\n3. Switching to a different model (if available)...";
50
45
(try
51
-
Client.set_model client (Model.of_string "claude-sonnet-4");
46
+
Client.set_model client (Proto.Model.of_string "claude-sonnet-4");
52
47
traceln "Model switched successfully";
53
48
54
49
(* Query with new model *)
55
50
Client.query client "Confirm your model again please.";
56
-
let messages = Client.receive_all client in
51
+
let responses = Client.receive_all client in
57
52
List.iter
58
53
(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)
54
+
| Response.Text text ->
55
+
traceln "Assistant (new model): %s" (Response.Text.content text)
67
56
| _ -> ())
68
-
messages
57
+
responses
69
58
with
70
59
| Failure msg -> traceln "Failed to switch model: %s" msg
71
60
| exn -> traceln "Error switching model: %s" (Printexc.to_string exn));
+36
-63
test/hooks_example.ml
+36
-63
test/hooks_example.ml
···
5
5
module Log = (val Logs.src_log src : Logs.LOG)
6
6
7
7
(* Example 1: Block dangerous bash commands *)
8
-
let block_dangerous_bash ~input ~tool_use_id:_ ~context:_ =
9
-
let hook = Claude.Hooks.PreToolUse.of_json input in
10
-
let tool_name = Claude.Hooks.PreToolUse.tool_name hook in
11
-
12
-
if tool_name = "Bash" then
13
-
let tool_input = Claude.Hooks.PreToolUse.tool_input hook in
14
-
match Test_json_utils.get_string tool_input "command" with
8
+
let block_dangerous_bash input =
9
+
if input.Claude.Hooks.PreToolUse.tool_name = "Bash" then
10
+
match Claude.Tool_input.get_string input.Claude.Hooks.PreToolUse.tool_input "command" with
15
11
| Some command ->
16
12
if String.length command >= 6 && String.sub command 0 6 = "rm -rf" then begin
17
13
Log.app (fun m -> m "š« Blocked dangerous command: %s" command);
18
-
let output =
19
-
Claude.Hooks.PreToolUse.deny
20
-
~reason:"Command contains dangerous 'rm -rf' pattern" ()
21
-
in
22
-
Claude.Hooks.continue
23
-
~system_message:"Blocked dangerous rm -rf command"
24
-
~hook_specific_output:
25
-
(Claude.Hooks.PreToolUse.output_to_json output)
26
-
()
14
+
Claude.Hooks.PreToolUse.deny
15
+
~reason:"Command contains dangerous 'rm -rf' pattern" ()
27
16
end
28
-
else Claude.Hooks.continue ()
29
-
| _ -> Claude.Hooks.continue ()
30
-
else Claude.Hooks.continue ()
17
+
else Claude.Hooks.PreToolUse.continue ()
18
+
| _ -> Claude.Hooks.PreToolUse.continue ()
19
+
else Claude.Hooks.PreToolUse.continue ()
31
20
32
21
(* Example 2: Log all tool usage *)
33
-
let log_tool_usage ~input ~tool_use_id ~context:_ =
34
-
let hook = Claude.Hooks.PreToolUse.of_json input in
35
-
let tool_name = Claude.Hooks.PreToolUse.tool_name hook in
36
-
let tool_use_id_str = Option.value tool_use_id ~default:"<none>" in
37
-
Log.app (fun m -> m "š Tool %s called (ID: %s)" tool_name tool_use_id_str);
38
-
Claude.Hooks.continue ()
22
+
let log_tool_usage input =
23
+
Log.app (fun m -> m "š Tool %s called" input.Claude.Hooks.PreToolUse.tool_name);
24
+
Claude.Hooks.PreToolUse.continue ()
39
25
40
26
let run_example ~sw ~env =
41
27
Log.app (fun m -> m "š§ Hooks System Example");
···
44
30
(* Configure hooks *)
45
31
let hooks =
46
32
Claude.Hooks.empty
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
-
]
33
+
|> Claude.Hooks.on_pre_tool_use log_tool_usage
34
+
|> Claude.Hooks.on_pre_tool_use ~pattern:"Bash" block_dangerous_bash
54
35
in
55
36
56
37
let options =
57
-
Claude.Options.create ~model:(Claude.Model.of_string "sonnet") ~hooks ()
38
+
Claude.Options.default
39
+
|> Claude.Options.with_model (Claude.Model.of_string "sonnet")
40
+
|> Claude.Options.with_hooks hooks
58
41
in
59
42
60
43
let client =
···
67
50
68
51
let messages = Claude.Client.receive_all client in
69
52
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")
53
+
(fun resp ->
54
+
match resp with
55
+
| Claude.Response.Text text ->
56
+
let content = Claude.Response.Text.content text in
57
+
if String.length content > 0 then
58
+
Log.app (fun m -> m "Claude: %s" content)
59
+
| Claude.Response.Complete _ ->
60
+
Log.app (fun m -> m "ā
Test 1 complete\n")
61
+
| Claude.Response.Error err ->
62
+
Log.err (fun m -> m "ā Error: %s" (Claude.Response.Error.message err))
85
63
| _ -> ())
86
64
messages;
87
65
···
91
69
92
70
let messages = Claude.Client.receive_all client in
93
71
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")
72
+
(fun resp ->
73
+
match resp with
74
+
| Claude.Response.Text text ->
75
+
let content = Claude.Response.Text.content text in
76
+
if String.length content > 0 then
77
+
Log.app (fun m -> m "Claude: %s" content)
78
+
| Claude.Response.Complete _ ->
79
+
Log.app (fun m -> m "ā
Test 2 complete")
80
+
| Claude.Response.Error err ->
81
+
Log.err (fun m -> m "ā Error: %s" (Claude.Response.Error.message err))
109
82
| _ -> ())
110
83
messages;
111
84
+42
-40
test/permission_demo.ml
+42
-40
test/permission_demo.ml
···
30
30
end
31
31
32
32
(* Interactive permission callback *)
33
-
let interactive_permission_callback ~tool_name ~input ~context:_ =
33
+
let interactive_permission_callback ctx =
34
+
let open Claude.Permissions in
35
+
let tool_name = ctx.tool_name in
36
+
let input = ctx.input in
37
+
34
38
Log.info (fun m -> m "š Permission callback invoked for tool: %s" tool_name);
35
39
Log.app (fun m -> m "\nš PERMISSION REQUEST š");
36
40
Log.app (fun m -> m "Tool: %s" tool_name);
37
41
38
42
(* Log the full input for debugging *)
39
-
Log.info (fun m -> m "Full input JSON: %s" (Test_json_utils.to_string input));
43
+
let input_json = Claude.Tool_input.to_json input in
44
+
Log.info (fun m -> m "Full input JSON: %s" (Test_json_utils.to_string input_json));
40
45
41
46
(* Show input details *)
42
47
(* Try to extract key information from the input *)
43
48
(try
44
49
match tool_name with
45
50
| "Read" -> (
46
-
match Test_json_utils.get_string input "file_path" with
51
+
match Test_json_utils.get_string input_json "file_path" with
47
52
| Some file_path -> Log.app (fun m -> m "File: %s" file_path)
48
53
| None -> ())
49
54
| "Bash" -> (
50
-
match Test_json_utils.get_string input "command" with
55
+
match Test_json_utils.get_string input_json "command" with
51
56
| Some command -> Log.app (fun m -> m "Command: %s" command)
52
57
| None -> ())
53
58
| "Write" | "Edit" -> (
54
-
match Test_json_utils.get_string input "file_path" with
59
+
match Test_json_utils.get_string input_json "file_path" with
55
60
| Some file_path -> Log.app (fun m -> m "File: %s" file_path)
56
61
| None -> ())
57
62
| "Glob" -> (
58
-
match Test_json_utils.get_string input "pattern" with
63
+
match Test_json_utils.get_string input_json "pattern" with
59
64
| Some pattern -> (
60
65
Log.app (fun m -> m "Pattern: %s" pattern);
61
-
match Test_json_utils.get_string input "path" with
66
+
match Test_json_utils.get_string input_json "path" with
62
67
| Some path -> Log.app (fun m -> m "Path: %s" path)
63
68
| None -> Log.app (fun m -> m "Path: (current directory)"))
64
69
| None -> ())
65
70
| "Grep" -> (
66
-
match Test_json_utils.get_string input "pattern" with
71
+
match Test_json_utils.get_string input_json "pattern" with
67
72
| Some pattern -> (
68
73
Log.app (fun m -> m "Pattern: %s" pattern);
69
-
match Test_json_utils.get_string input "path" with
74
+
match Test_json_utils.get_string input_json "path" with
70
75
| Some path -> Log.app (fun m -> m "Path: %s" path)
71
76
| None -> Log.app (fun m -> m "Path: (current directory)"))
72
77
| None -> ())
73
-
| _ -> Log.app (fun m -> m "Input: %s" (Test_json_utils.to_string input))
78
+
| _ -> Log.app (fun m -> m "Input: %s" (Test_json_utils.to_string input_json))
74
79
with exn ->
75
80
Log.info (fun m ->
76
81
m "Failed to parse input details: %s" (Printexc.to_string exn)));
···
79
84
if Granted.is_granted tool_name then begin
80
85
Log.app (fun m -> m "ā Auto-approved (previously granted)");
81
86
Log.info (fun m -> m "Returning allow result for %s" tool_name);
82
-
Claude.Permissions.Result.allow ()
87
+
Decision.allow ()
83
88
end
84
89
else begin
85
90
(* Ask user - read from /dev/tty since stdin is connected to Claude process *)
···
91
96
| "y" | "yes" ->
92
97
Log.app (fun m -> m "ā Allowed (this time only)");
93
98
Log.info (fun m -> m "User approved %s for this request only" tool_name);
94
-
Claude.Permissions.Result.allow ()
99
+
Decision.allow ()
95
100
| "a" | "always" ->
96
101
Granted.grant tool_name;
97
102
Log.info (fun m ->
98
103
m "User granted permanent permission for %s" tool_name);
99
-
Claude.Permissions.Result.allow ()
104
+
Decision.allow ()
100
105
| _ ->
101
106
Granted.deny tool_name;
102
107
Log.info (fun m -> m "User denied permission for %s" tool_name);
103
-
Claude.Permissions.Result.deny
108
+
Decision.deny
104
109
~message:(Printf.sprintf "User denied access to %s" tool_name)
105
-
~interrupt:false ()
110
+
~interrupt:false
106
111
end
107
112
108
113
let process_response client =
109
-
let messages = Claude.Client.receive_all client in
114
+
let responses = Claude.Client.receive_all client in
110
115
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
116
+
(fun response ->
117
+
match response with
118
+
| Claude.Response.Text t ->
119
+
let text = Claude.Response.Text.content t in
120
+
Log.app (fun m -> m "\nš Claude says:\n%s" text)
121
+
| Claude.Response.Tool_use t ->
122
+
Log.info (fun m ->
123
+
m "š§ Tool use: %s (id: %s)"
124
+
(Claude.Response.Tool_use.name t)
125
+
(Claude.Response.Tool_use.id t))
126
+
| Claude.Response.Complete c ->
127
+
(if Claude.Response.Complete.result_text c = None then
128
128
Log.err (fun m -> m "ā Error occurred!")
129
129
else
130
-
match Claude.Message.Result.total_cost_usd msg with
130
+
match Claude.Response.Complete.total_cost_usd c with
131
131
| Some cost -> Log.info (fun m -> m "š° Cost: $%.6f" cost)
132
132
| None -> ());
133
133
Log.info (fun m ->
134
-
m "ā±ļø Duration: %dms" (Claude.Message.Result.duration_ms msg))
134
+
m "ā±ļø Duration: %dms" (Claude.Response.Complete.duration_ms c))
135
+
| Claude.Response.Error e ->
136
+
Log.err (fun m -> m "ā Error: %s" (Claude.Response.Error.message e))
135
137
| _ -> ())
136
-
messages
138
+
responses
137
139
138
140
let run_demo ~sw ~env =
139
141
Log.app (fun m -> m "š Starting Permission Demo");
···
145
147
(* DON'T specify allowed_tools - let the permission callback handle everything.
146
148
The Default permission mode with a callback should send requests for all tools. *)
147
149
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 ()
150
+
Claude.Options.default
151
+
|> Claude.Options.with_model (Claude.Model.of_string "sonnet")
152
+
|> Claude.Options.with_permission_mode Claude.Permissions.Mode.Default
153
+
|> Claude.Options.with_permission_callback interactive_permission_callback
152
154
in
153
155
154
156
let client =
+36
-54
test/simple_permission_test.ml
+36
-54
test/simple_permission_test.ml
···
5
5
module Log = (val Logs.src_log src : Logs.LOG)
6
6
7
7
(* Auto-allow callback that logs what it sees *)
8
-
let auto_allow_callback ~tool_name ~input ~context:_ =
8
+
let auto_allow_callback ctx =
9
9
Log.app (fun m -> m "\nš Permission callback invoked!");
10
-
Log.app (fun m -> m " Tool: %s" tool_name);
11
-
Log.app (fun m -> m " Input: %s" (Test_json_utils.to_string input));
10
+
Log.app (fun m -> m " Tool: %s" ctx.Claude.Permissions.tool_name);
11
+
Log.app (fun m -> m " Input: %s" (Test_json_utils.to_string (Claude.Tool_input.to_json ctx.Claude.Permissions.input)));
12
12
Log.app (fun m -> m " ā
Auto-allowing");
13
-
Claude.Permissions.Result.allow ()
13
+
Claude.Permissions.Decision.allow ()
14
14
15
15
let run_test ~sw ~env =
16
16
Log.app (fun m -> m "š§Ŗ Testing Permission Callbacks (Auto-Allow Mode)");
···
18
18
19
19
(* Create options with permission callback *)
20
20
let options =
21
-
Claude.Options.create
22
-
~model:(Claude.Model.of_string "sonnet")
23
-
~permission_callback:auto_allow_callback ()
21
+
Claude.Options.default
22
+
|> Claude.Options.with_model (Claude.Model.of_string "sonnet")
23
+
|> Claude.Options.with_permission_callback auto_allow_callback
24
24
in
25
25
26
26
Log.app (fun m -> m "Creating client with permission callback...");
···
41
41
let write_used = ref false in
42
42
43
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
44
+
(fun resp ->
45
+
match resp with
46
+
| Claude.Response.Text text ->
47
+
let content = Claude.Response.Text.content text in
48
+
if String.length content > 0 then
49
+
Log.app (fun m -> m "\nš¬ Claude: %s" content)
50
+
| Claude.Response.Tool_use t ->
51
+
incr tool_count;
52
+
let tool_name = Claude.Response.Tool_use.name t in
53
+
if tool_name = "Write" then write_used := true;
54
+
Log.app (fun m -> m "š§ Tool use #%d: %s" !tool_count tool_name)
55
+
| Claude.Response.Tool_result r ->
56
+
let tool_use_id = Claude.Content_block.Tool_result.tool_use_id r in
57
+
let is_error =
58
+
Claude.Content_block.Tool_result.is_error r
59
+
|> Option.value ~default:false
60
+
in
61
+
if is_error then begin
62
+
Log.app (fun m -> m "\nā ļø Tool result error for %s:" tool_use_id);
63
+
match Claude.Content_block.Tool_result.content r with
64
+
| Some s -> Log.app (fun m -> m " %s" s)
65
+
| None -> ()
66
+
end
67
+
| Claude.Response.Complete result ->
68
+
Log.app (fun m -> m "\nā
Success!");
69
+
(match Claude.Response.Complete.total_cost_usd result with
90
70
| Some cost -> Log.app (fun m -> m "š° Cost: $%.6f" cost)
91
71
| None -> ());
92
72
Log.app (fun m ->
93
-
m "ā±ļø Duration: %dms" (Claude.Message.Result.duration_ms msg))
73
+
m "ā±ļø Duration: %dms" (Claude.Response.Complete.duration_ms result))
74
+
| Claude.Response.Error err ->
75
+
Log.err (fun m -> m "\nā Error: %s" (Claude.Response.Error.message err))
94
76
| _ -> ())
95
77
messages;
96
78
+47
-27
test/simulated_permissions.ml
+47
-27
test/simulated_permissions.ml
···
42
42
end
43
43
44
44
(* Example permission callback *)
45
-
let example_permission_callback ~tool_name ~input:_ ~context:_ =
45
+
let example_permission_callback ctx =
46
+
let open Claude.Permissions in
47
+
let tool_name = ctx.tool_name in
48
+
46
49
Log.app (fun m -> m "\nš Permission Request for: %s" tool_name);
47
50
48
51
(* Check current state *)
49
52
if PermissionState.is_granted tool_name then begin
50
53
Log.app (fun m -> m " ā Auto-approved (previously granted)");
51
-
Claude.Permissions.Result.allow ()
54
+
Decision.allow ()
52
55
end
53
56
else if PermissionState.is_denied tool_name then begin
54
57
Log.app (fun m -> m " ā Auto-denied (previously denied)");
55
-
Claude.Permissions.Result.deny
58
+
Decision.deny
56
59
~message:(Printf.sprintf "Tool %s is blocked by policy" tool_name)
57
-
~interrupt:false ()
60
+
~interrupt:false
58
61
end
59
62
else begin
60
63
(* Ask user *)
···
62
65
match read_line () |> String.lowercase_ascii with
63
66
| "y" | "yes" ->
64
67
Log.app (fun m -> m " ā Allowed (one time)");
65
-
Claude.Permissions.Result.allow ()
68
+
Decision.allow ()
66
69
| "n" | "no" ->
67
70
Log.app (fun m -> m " ā Denied (one time)");
68
-
Claude.Permissions.Result.deny
71
+
Decision.deny
69
72
~message:(Printf.sprintf "User denied %s" tool_name)
70
-
~interrupt:false ()
73
+
~interrupt:false
71
74
| "a" | "always" ->
72
75
PermissionState.grant tool_name;
73
76
Log.app (fun m -> m " ā Allowed (always)");
74
-
Claude.Permissions.Result.allow ()
77
+
Decision.allow ()
75
78
| "never" ->
76
79
PermissionState.deny tool_name;
77
80
Log.app (fun m -> m " ā Denied (always)");
78
-
Claude.Permissions.Result.deny
81
+
Decision.deny
79
82
~message:(Printf.sprintf "Tool %s permanently blocked" tool_name)
80
-
~interrupt:false ()
83
+
~interrupt:false
81
84
| _ ->
82
85
Log.app (fun m -> m " ā Denied (invalid response)");
83
-
Claude.Permissions.Result.deny ~message:"Invalid permission response"
84
-
~interrupt:false ()
86
+
Decision.deny ~message:"Invalid permission response"
87
+
~interrupt:false
85
88
end
86
89
87
90
(* Demonstrate the permission system *)
···
91
94
92
95
(* Simulate permission requests *)
93
96
let tools = [ "Read"; "Write"; "Bash"; "Edit" ] in
94
-
let context = Claude.Permissions.Context.create () in
95
97
96
98
Log.app (fun m -> m "This demo simulates permission requests.");
97
99
Log.app (fun m -> m "You can respond with: y/n/always/never\n");
98
100
99
101
(* Test each tool *)
100
102
List.iter
101
-
(fun tool ->
103
+
(fun tool_name ->
102
104
let input =
103
105
let open Jsont in
104
106
Object
···
107
109
],
108
110
Meta.none )
109
111
in
110
-
let result =
111
-
example_permission_callback ~tool_name:tool ~input ~context
112
+
let tool_input = Claude.Tool_input.of_json input in
113
+
let ctx =
114
+
Claude.Permissions.
115
+
{
116
+
tool_name;
117
+
input = tool_input;
118
+
suggested_rules = [];
119
+
}
112
120
in
121
+
let decision = example_permission_callback ctx in
113
122
114
123
(* 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))
124
+
if Claude.Permissions.Decision.is_allow decision then
125
+
Log.info (fun m -> m "Result: Permission granted for %s" tool_name)
126
+
else
127
+
match Claude.Permissions.Decision.deny_message decision with
128
+
| Some message ->
129
+
Log.info (fun m ->
130
+
m "Result: Permission denied for %s - %s" tool_name message)
131
+
| None ->
132
+
Log.info (fun m -> m "Result: Permission denied for %s" tool_name))
121
133
tools;
122
134
123
135
(* Show final state *)
···
129
141
Log.app (fun m -> m "====================================\n");
130
142
131
143
let discovered = ref [] in
132
-
let callback = Claude.Permissions.discovery_callback discovered in
144
+
let callback = Claude.Permissions.discovery discovered in
133
145
134
146
(* Simulate some tool requests *)
135
147
let requests =
···
153
165
Log.app (fun m -> m "Simulating tool requests with discovery callback...\n");
154
166
155
167
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
168
+
(fun (tool_name, input) ->
169
+
Log.app (fun m -> m " Request: %s" tool_name);
170
+
let tool_input = Claude.Tool_input.of_json input in
171
+
let ctx =
172
+
Claude.Permissions.
173
+
{
174
+
tool_name;
175
+
input = tool_input;
176
+
suggested_rules = [];
177
+
}
178
+
in
179
+
let _ = callback ctx in
160
180
())
161
181
requests;
162
182
+16
-22
test/structured_output_demo.ml
+16
-22
test/structured_output_demo.ml
···
100
100
in
101
101
102
102
(* Create structured output format from the schema *)
103
-
let output_format = C.Structured_output.of_json_schema analysis_schema in
103
+
let output_format = Claude.Proto.Structured_output.of_json_schema analysis_schema in
104
104
105
105
(* Configure Claude with structured output *)
106
106
let options =
···
132
132
C.Client.query client prompt;
133
133
134
134
(* Process responses *)
135
-
let messages = C.Client.receive client in
135
+
let responses = C.Client.receive client in
136
136
Seq.iter
137
137
(function
138
-
| C.Message.Assistant msg ->
139
-
Printf.printf "\nAssistant response:\n";
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 -> (
138
+
| C.Response.Text text ->
139
+
Printf.printf "\nAssistant text:\n";
140
+
Printf.printf " %s\n" (C.Response.Text.content text)
141
+
| C.Response.Tool_use tool ->
142
+
Printf.printf " Using tool: %s\n" (C.Response.Tool_use.name tool)
143
+
| C.Response.Complete result -> (
150
144
Printf.printf "\n=== Result ===\n";
151
-
Printf.printf "Duration: %dms\n" (C.Message.Result.duration_ms result);
145
+
Printf.printf "Duration: %dms\n" (C.Response.Complete.duration_ms result);
152
146
Printf.printf "Cost: $%.4f\n"
153
-
(Option.value (C.Message.Result.total_cost_usd result) ~default:0.0);
147
+
(Option.value (C.Response.Complete.total_cost_usd result) ~default:0.0);
154
148
155
149
(* Extract and display structured output *)
156
-
match C.Message.Result.structured_output result with
150
+
match C.Response.Complete.structured_output result with
157
151
| Some output ->
158
152
Printf.printf "\n=== Structured Output ===\n";
159
153
Printf.printf "%s\n\n"
···
196
190
findings
197
191
| None -> (
198
192
Printf.printf "No structured output received\n";
199
-
match C.Message.Result.result result with
193
+
match C.Response.Complete.result_text result with
200
194
| Some text -> Printf.printf "Text result: %s\n" text
201
195
| None -> ()))
202
-
| C.Message.System (C.Message.System.Init _) ->
203
-
Printf.printf "Session initialized\n"
204
-
| C.Message.System (C.Message.System.Error _) -> ()
196
+
| C.Response.Init _ -> Printf.printf "Session initialized\n"
197
+
| C.Response.Error err ->
198
+
Printf.printf "Error: %s\n" (C.Response.Error.message err)
205
199
| _ -> ())
206
-
messages;
200
+
responses;
207
201
208
202
Printf.printf "\nDone!\n"
209
203
+7
-5
test/structured_output_simple.ml
+7
-5
test/structured_output_simple.ml
···
44
44
Meta.none )
45
45
in
46
46
47
-
let output_format = C.Structured_output.of_json_schema person_schema in
47
+
let output_format = Claude.Proto.Structured_output.of_json_schema person_schema in
48
48
49
49
let options =
50
50
C.Options.default
···
62
62
"Tell me about a famous computer scientist. Provide their name, age, and \
63
63
occupation in the exact JSON structure I specified.";
64
64
65
-
let messages = C.Client.receive_all client in
65
+
let responses = C.Client.receive_all client in
66
66
List.iter
67
67
(function
68
-
| C.Message.Result result -> (
68
+
| C.Response.Complete result -> (
69
69
Printf.printf "Response received!\n";
70
-
match C.Message.Result.structured_output result with
70
+
match C.Response.Complete.structured_output result with
71
71
| Some json ->
72
72
Printf.printf "\nStructured Output:\n%s\n"
73
73
(Test_json_utils.to_string ~minify:false json)
74
74
| None -> Printf.printf "No structured output\n")
75
+
| C.Response.Error err ->
76
+
Printf.printf "Error: %s\n" (C.Response.Error.message err)
75
77
| _ -> ())
76
-
messages
78
+
responses
77
79
78
80
let () =
79
81
Eio_main.run @@ fun env ->
+14
-16
test/test_incoming.ml
+14
-16
test/test_incoming.ml
···
1
1
(** Test the Incoming message codec *)
2
2
3
-
open Claude
4
-
5
3
let test_decode_user_message () =
6
4
let json_str = {|{"type":"user","content":"Hello"}|} in
7
-
match Jsont_bytesrw.decode_string' Incoming.jsont json_str with
8
-
| Ok (Incoming.Message (Message.User _)) ->
5
+
match Jsont_bytesrw.decode_string' Proto.Incoming.jsont json_str with
6
+
| Ok (Proto.Incoming.Message (Proto.Message.User _)) ->
9
7
print_endline "ā Decoded user message successfully"
10
8
| Ok _ -> print_endline "ā Wrong message type decoded"
11
9
| Error err ->
···
16
14
let json_str =
17
15
{|{"type":"assistant","model":"claude-sonnet-4","content":[{"type":"text","text":"Hi"}]}|}
18
16
in
19
-
match Jsont_bytesrw.decode_string' Incoming.jsont json_str with
20
-
| Ok (Incoming.Message (Message.Assistant _)) ->
17
+
match Jsont_bytesrw.decode_string' Proto.Incoming.jsont json_str with
18
+
| Ok (Proto.Incoming.Message (Proto.Message.Assistant _)) ->
21
19
print_endline "ā Decoded assistant message successfully"
22
20
| Ok _ -> print_endline "ā Wrong message type decoded"
23
21
| Error err ->
···
28
26
let json_str =
29
27
{|{"type":"system","subtype":"init","data":{"session_id":"test-123"}}|}
30
28
in
31
-
match Jsont_bytesrw.decode_string' Incoming.jsont json_str with
32
-
| Ok (Incoming.Message (Message.System _)) ->
29
+
match Jsont_bytesrw.decode_string' Proto.Incoming.jsont json_str with
30
+
| Ok (Proto.Incoming.Message (Proto.Message.System _)) ->
33
31
print_endline "ā Decoded system message successfully"
34
32
| Ok _ -> print_endline "ā Wrong message type decoded"
35
33
| Error err ->
···
40
38
let json_str =
41
39
{|{"type":"control_response","response":{"subtype":"success","request_id":"test-req-1"}}|}
42
40
in
43
-
match Jsont_bytesrw.decode_string' Incoming.jsont json_str with
44
-
| Ok (Incoming.Control_response resp) -> (
41
+
match Jsont_bytesrw.decode_string' Proto.Incoming.jsont json_str with
42
+
| Ok (Proto.Incoming.Control_response resp) -> (
45
43
match resp.response with
46
-
| Sdk_control.Response.Success s ->
44
+
| Proto.Control.Response.Success s ->
47
45
if s.request_id = "test-req-1" then
48
46
print_endline "ā Decoded control response successfully"
49
47
else Printf.printf "ā Wrong request_id: %s\n" s.request_id
50
-
| Sdk_control.Response.Error _ ->
48
+
| Proto.Control.Response.Error _ ->
51
49
print_endline "ā Got error response instead of success")
52
50
| Ok _ -> print_endline "ā Wrong message type decoded"
53
51
| Error err ->
···
58
56
let json_str =
59
57
{|{"type":"control_response","response":{"subtype":"error","request_id":"test-req-2","error":"Something went wrong"}}|}
60
58
in
61
-
match Jsont_bytesrw.decode_string' Incoming.jsont json_str with
62
-
| Ok (Incoming.Control_response resp) -> (
59
+
match Jsont_bytesrw.decode_string' Proto.Incoming.jsont json_str with
60
+
| Ok (Proto.Incoming.Control_response resp) -> (
63
61
match resp.response with
64
-
| Sdk_control.Response.Error e ->
62
+
| Proto.Control.Response.Error e ->
65
63
if e.request_id = "test-req-2" && e.error = "Something went wrong"
66
64
then print_endline "ā Decoded control error response successfully"
67
65
else Printf.printf "ā Wrong error content\n"
68
-
| Sdk_control.Response.Success _ ->
66
+
| Proto.Control.Response.Success _ ->
69
67
print_endline "ā Got success response instead of error")
70
68
| Ok _ -> print_endline "ā Wrong message type decoded"
71
69
| Error err ->
+18
-24
test/test_permissions.ml
+18
-24
test/test_permissions.ml
···
5
5
module Log = (val Logs.src_log src : Logs.LOG)
6
6
7
7
(* Simple auto-allow permission callback *)
8
-
let auto_allow_callback ~tool_name ~input:_ ~context:_ =
9
-
Log.app (fun m -> m "ā
Auto-allowing tool: %s" tool_name);
10
-
Claude.Permissions.Result.allow ()
8
+
let auto_allow_callback ctx =
9
+
Log.app (fun m -> m "ā
Auto-allowing tool: %s" ctx.Claude.Permissions.tool_name);
10
+
Claude.Permissions.Decision.allow ()
11
11
12
12
let run_test ~sw ~env =
13
13
Log.app (fun m -> m "š§Ŗ Testing Permission Callbacks");
···
15
15
16
16
(* Create options with custom permission callback *)
17
17
let options =
18
-
Claude.Options.create
19
-
~model:(Claude.Model.of_string "sonnet")
20
-
~permission_callback:auto_allow_callback ()
18
+
Claude.Options.default
19
+
|> Claude.Options.with_model (Claude.Model.of_string "sonnet")
20
+
|> Claude.Options.with_permission_callback auto_allow_callback
21
21
in
22
22
23
23
Log.app (fun m -> m "Creating client with permission callback...");
···
34
34
Log.app (fun m -> m "\nšØ Received %d messages" (List.length messages));
35
35
36
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!");
37
+
(fun resp ->
38
+
match resp with
39
+
| Claude.Response.Text text ->
40
+
Log.app (fun m -> m "Claude: %s" (Claude.Response.Text.content text))
41
+
| Claude.Response.Tool_use t ->
42
+
Log.app (fun m ->
43
+
m "š§ Tool use: %s" (Claude.Response.Tool_use.name t))
44
+
| Claude.Response.Complete result ->
45
+
Log.app (fun m -> m "ā
Success!");
54
46
Log.app (fun m ->
55
-
m "Duration: %dms" (Claude.Message.Result.duration_ms msg))
47
+
m "Duration: %dms" (Claude.Response.Complete.duration_ms result))
48
+
| Claude.Response.Error err ->
49
+
Log.err (fun m -> m "ā Error: %s" (Claude.Response.Error.message err))
56
50
| _ -> ())
57
51
messages;
58
52