OCaml Claude SDK using Eio and Jsont
trim
-7452
-67
lib/err.ml
-67
lib/err.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Error handling for claudeio. *)
7
-
8
-
type t =
9
-
| Cli_not_found of string
10
-
| Process_error of string
11
-
| Connection_error of string
12
-
| Protocol_error of string
13
-
| Timeout of string
14
-
| Permission_denied of { tool_name : string; message : string }
15
-
| Hook_error of { callback_id : string; message : string }
16
-
| Control_error of { request_id : string; message : string }
17
-
18
-
exception E of t
19
-
20
-
let pp ppf = function
21
-
| Cli_not_found msg -> Fmt.pf ppf "CLI not found: %s" msg
22
-
| Process_error msg -> Fmt.pf ppf "Process error: %s" msg
23
-
| Connection_error msg -> Fmt.pf ppf "Connection error: %s" msg
24
-
| Protocol_error msg -> Fmt.pf ppf "Protocol error: %s" msg
25
-
| Timeout msg -> Fmt.pf ppf "Timeout: %s" msg
26
-
| Permission_denied { tool_name; message } ->
27
-
Fmt.pf ppf "Permission denied for tool '%s': %s" tool_name message
28
-
| Hook_error { callback_id; message } ->
29
-
Fmt.pf ppf "Hook error (callback_id=%s): %s" callback_id message
30
-
| Control_error { request_id; message } ->
31
-
Fmt.pf ppf "Control error (request_id=%s): %s" request_id message
32
-
33
-
let to_string err = Fmt.str "%a" pp err
34
-
let raise err = Stdlib.raise (E err)
35
-
36
-
(* Register exception printer for better error messages *)
37
-
let () =
38
-
Printexc.register_printer (function
39
-
| E err -> Some (to_string err)
40
-
| _ -> None)
41
-
42
-
(** {1 Convenience Raisers} *)
43
-
44
-
let cli_not_found msg = raise (Cli_not_found msg)
45
-
let process_error msg = raise (Process_error msg)
46
-
let connection_error msg = raise (Connection_error msg)
47
-
let protocol_error msg = raise (Protocol_error msg)
48
-
let timeout msg = raise (Timeout msg)
49
-
50
-
let permission_denied ~tool_name ~message =
51
-
raise (Permission_denied { tool_name; message })
52
-
53
-
let hook_error ~callback_id ~message =
54
-
raise (Hook_error { callback_id; message })
55
-
56
-
let control_error ~request_id ~message =
57
-
raise (Control_error { request_id; message })
58
-
59
-
(** {1 Result Helpers} *)
60
-
61
-
let get_ok ~msg = function
62
-
| Ok x -> x
63
-
| Error e -> raise (Protocol_error (msg ^ e))
64
-
65
-
let get_ok' ~msg = function
66
-
| Ok x -> x
67
-
| Error e -> raise (Protocol_error (msg ^ e))
-48
lib/err.mli
-48
lib/err.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Error handling for claudeio. *)
7
-
8
-
type t =
9
-
| Cli_not_found of string
10
-
| Process_error of string
11
-
| Connection_error of string
12
-
| Protocol_error of string
13
-
| Timeout of string
14
-
| Permission_denied of { tool_name : string; message : string }
15
-
| Hook_error of { callback_id : string; message : string }
16
-
| Control_error of { request_id : string; message : string }
17
-
18
-
exception E of t
19
-
20
-
val pp : Format.formatter -> t -> unit
21
-
(** Pretty-print an error. *)
22
-
23
-
val to_string : t -> string
24
-
(** Convert error to string. *)
25
-
26
-
val raise : t -> 'a
27
-
(** [raise err] raises [E err]. *)
28
-
29
-
(** {1 Convenience Raisers} *)
30
-
31
-
val cli_not_found : string -> 'a
32
-
val process_error : string -> 'a
33
-
val connection_error : string -> 'a
34
-
val protocol_error : string -> 'a
35
-
val timeout : string -> 'a
36
-
val permission_denied : tool_name:string -> message:string -> 'a
37
-
val hook_error : callback_id:string -> message:string -> 'a
38
-
val control_error : request_id:string -> message:string -> 'a
39
-
40
-
(** {1 Result Helpers} *)
41
-
42
-
val get_ok : msg:string -> ('a, string) result -> 'a
43
-
(** [get_ok ~msg result] returns the Ok value or raises Protocol_error with msg
44
-
prefix. *)
45
-
46
-
val get_ok' : msg:string -> ('a, string) result -> 'a
47
-
(** [get_ok' ~msg result] returns the Ok value or raises Protocol_error with
48
-
string error. *)
-490
lib/sdk_control.ml
-490
lib/sdk_control.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
let src =
7
-
Logs.Src.create "claude.sdk_control" ~doc:"Claude SDK control protocol"
8
-
9
-
module Log = (val Logs.src_log src : Logs.LOG)
10
-
11
-
module Request = struct
12
-
type interrupt = { subtype : [ `Interrupt ]; unknown : Unknown.t }
13
-
14
-
type permission = {
15
-
subtype : [ `Can_use_tool ];
16
-
tool_name : string;
17
-
input : Jsont.json;
18
-
permission_suggestions : Proto.Permissions.Update.t list option;
19
-
blocked_path : string option;
20
-
unknown : Unknown.t;
21
-
}
22
-
23
-
type initialize = {
24
-
subtype : [ `Initialize ];
25
-
hooks : (string * Jsont.json) list option;
26
-
unknown : Unknown.t;
27
-
}
28
-
29
-
type set_permission_mode = {
30
-
subtype : [ `Set_permission_mode ];
31
-
mode : Proto.Permissions.Mode.t;
32
-
unknown : Unknown.t;
33
-
}
34
-
35
-
type hook_callback = {
36
-
subtype : [ `Hook_callback ];
37
-
callback_id : string;
38
-
input : Jsont.json;
39
-
tool_use_id : string option;
40
-
unknown : Unknown.t;
41
-
}
42
-
43
-
type mcp_message = {
44
-
subtype : [ `Mcp_message ];
45
-
server_name : string;
46
-
message : Jsont.json;
47
-
unknown : Unknown.t;
48
-
}
49
-
50
-
type set_model = {
51
-
subtype : [ `Set_model ];
52
-
model : string;
53
-
unknown : Unknown.t;
54
-
}
55
-
56
-
type get_server_info = { subtype : [ `Get_server_info ]; unknown : Unknown.t }
57
-
58
-
type t =
59
-
| Interrupt of interrupt
60
-
| Permission of permission
61
-
| Initialize of initialize
62
-
| Set_permission_mode of set_permission_mode
63
-
| Hook_callback of hook_callback
64
-
| Mcp_message of mcp_message
65
-
| Set_model of set_model
66
-
| Get_server_info of get_server_info
67
-
68
-
let interrupt ?(unknown = Unknown.empty) () =
69
-
Interrupt { subtype = `Interrupt; unknown }
70
-
71
-
let permission ~tool_name ~input ?permission_suggestions ?blocked_path
72
-
?(unknown = Unknown.empty) () =
73
-
Permission
74
-
{
75
-
subtype = `Can_use_tool;
76
-
tool_name;
77
-
input;
78
-
permission_suggestions;
79
-
blocked_path;
80
-
unknown;
81
-
}
82
-
83
-
let initialize ?hooks ?(unknown = Unknown.empty) () =
84
-
Initialize { subtype = `Initialize; hooks; unknown }
85
-
86
-
let set_permission_mode ~mode ?(unknown = Unknown.empty) () =
87
-
Set_permission_mode { subtype = `Set_permission_mode; mode; unknown }
88
-
89
-
let hook_callback ~callback_id ~input ?tool_use_id ?(unknown = Unknown.empty)
90
-
() =
91
-
Hook_callback
92
-
{ subtype = `Hook_callback; callback_id; input; tool_use_id; unknown }
93
-
94
-
let mcp_message ~server_name ~message ?(unknown = Unknown.empty) () =
95
-
Mcp_message { subtype = `Mcp_message; server_name; message; unknown }
96
-
97
-
let set_model ~model ?(unknown = Unknown.empty) () =
98
-
Set_model { subtype = `Set_model; model; unknown }
99
-
100
-
let get_server_info ?(unknown = Unknown.empty) () =
101
-
Get_server_info { subtype = `Get_server_info; unknown }
102
-
103
-
(* Individual record codecs *)
104
-
let interrupt_jsont : interrupt Jsont.t =
105
-
let make (unknown : Unknown.t) : interrupt =
106
-
{ subtype = `Interrupt; unknown }
107
-
in
108
-
Jsont.Object.map ~kind:"Interrupt" make
109
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : interrupt) ->
110
-
r.unknown)
111
-
|> Jsont.Object.finish
112
-
113
-
let permission_jsont : permission Jsont.t =
114
-
let make tool_name input permission_suggestions blocked_path
115
-
(unknown : Unknown.t) : permission =
116
-
{
117
-
subtype = `Can_use_tool;
118
-
tool_name;
119
-
input;
120
-
permission_suggestions;
121
-
blocked_path;
122
-
unknown;
123
-
}
124
-
in
125
-
Jsont.Object.map ~kind:"Permission" make
126
-
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:(fun (r : permission) ->
127
-
r.tool_name)
128
-
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : permission) ->
129
-
r.input)
130
-
|> Jsont.Object.opt_mem "permission_suggestions"
131
-
(Jsont.list Proto.Permissions.Update.jsont)
132
-
~enc:(fun (r : permission) -> r.permission_suggestions)
133
-
|> Jsont.Object.opt_mem "blocked_path" Jsont.string
134
-
~enc:(fun (r : permission) -> r.blocked_path)
135
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : permission) ->
136
-
r.unknown)
137
-
|> Jsont.Object.finish
138
-
139
-
let initialize_jsont : initialize Jsont.t =
140
-
(* The hooks field is an object with string keys and json values *)
141
-
let hooks_map_jsont = Jsont.Object.as_string_map Jsont.json in
142
-
let module StringMap = Map.Make (String) in
143
-
let hooks_jsont =
144
-
Jsont.map
145
-
~dec:(fun m -> StringMap.bindings m)
146
-
~enc:(fun l -> StringMap.of_seq (List.to_seq l))
147
-
hooks_map_jsont
148
-
in
149
-
let make hooks (unknown : Unknown.t) : initialize =
150
-
{ subtype = `Initialize; hooks; unknown }
151
-
in
152
-
Jsont.Object.map ~kind:"Initialize" make
153
-
|> Jsont.Object.opt_mem "hooks" hooks_jsont ~enc:(fun (r : initialize) ->
154
-
r.hooks)
155
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : initialize) ->
156
-
r.unknown)
157
-
|> Jsont.Object.finish
158
-
159
-
let set_permission_mode_jsont : set_permission_mode Jsont.t =
160
-
let make mode (unknown : Unknown.t) : set_permission_mode =
161
-
{ subtype = `Set_permission_mode; mode; unknown }
162
-
in
163
-
Jsont.Object.map ~kind:"SetPermissionMode" make
164
-
|> Jsont.Object.mem "mode" Proto.Permissions.Mode.jsont
165
-
~enc:(fun (r : set_permission_mode) -> r.mode)
166
-
|> Jsont.Object.keep_unknown Jsont.json_mems
167
-
~enc:(fun (r : set_permission_mode) -> r.unknown)
168
-
|> Jsont.Object.finish
169
-
170
-
let hook_callback_jsont : hook_callback Jsont.t =
171
-
let make callback_id input tool_use_id (unknown : Unknown.t) : hook_callback
172
-
=
173
-
{ subtype = `Hook_callback; callback_id; input; tool_use_id; unknown }
174
-
in
175
-
Jsont.Object.map ~kind:"HookCallback" make
176
-
|> Jsont.Object.mem "callback_id" Jsont.string
177
-
~enc:(fun (r : hook_callback) -> r.callback_id)
178
-
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : hook_callback) ->
179
-
r.input)
180
-
|> Jsont.Object.opt_mem "tool_use_id" Jsont.string
181
-
~enc:(fun (r : hook_callback) -> r.tool_use_id)
182
-
|> Jsont.Object.keep_unknown Jsont.json_mems
183
-
~enc:(fun (r : hook_callback) -> r.unknown)
184
-
|> Jsont.Object.finish
185
-
186
-
let mcp_message_jsont : mcp_message Jsont.t =
187
-
let make server_name message (unknown : Unknown.t) : mcp_message =
188
-
{ subtype = `Mcp_message; server_name; message; unknown }
189
-
in
190
-
Jsont.Object.map ~kind:"McpMessage" make
191
-
|> Jsont.Object.mem "server_name" Jsont.string
192
-
~enc:(fun (r : mcp_message) -> r.server_name)
193
-
|> Jsont.Object.mem "message" Jsont.json ~enc:(fun (r : mcp_message) ->
194
-
r.message)
195
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : mcp_message) ->
196
-
r.unknown)
197
-
|> Jsont.Object.finish
198
-
199
-
let set_model_jsont : set_model Jsont.t =
200
-
let make model (unknown : Unknown.t) : set_model =
201
-
{ subtype = `Set_model; model; unknown }
202
-
in
203
-
Jsont.Object.map ~kind:"SetModel" make
204
-
|> Jsont.Object.mem "model" Jsont.string ~enc:(fun (r : set_model) ->
205
-
r.model)
206
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : set_model) ->
207
-
r.unknown)
208
-
|> Jsont.Object.finish
209
-
210
-
let get_server_info_jsont : get_server_info Jsont.t =
211
-
let make (unknown : Unknown.t) : get_server_info =
212
-
{ subtype = `Get_server_info; unknown }
213
-
in
214
-
Jsont.Object.map ~kind:"GetServerInfo" make
215
-
|> Jsont.Object.keep_unknown Jsont.json_mems
216
-
~enc:(fun (r : get_server_info) -> r.unknown)
217
-
|> Jsont.Object.finish
218
-
219
-
(* Main variant codec using subtype discriminator *)
220
-
let jsont : t Jsont.t =
221
-
let case_interrupt =
222
-
Jsont.Object.Case.map "interrupt" interrupt_jsont ~dec:(fun v ->
223
-
Interrupt v)
224
-
in
225
-
let case_permission =
226
-
Jsont.Object.Case.map "can_use_tool" permission_jsont ~dec:(fun v ->
227
-
Permission v)
228
-
in
229
-
let case_initialize =
230
-
Jsont.Object.Case.map "initialize" initialize_jsont ~dec:(fun v ->
231
-
Initialize v)
232
-
in
233
-
let case_set_permission_mode =
234
-
Jsont.Object.Case.map "set_permission_mode" set_permission_mode_jsont
235
-
~dec:(fun v -> Set_permission_mode v)
236
-
in
237
-
let case_hook_callback =
238
-
Jsont.Object.Case.map "hook_callback" hook_callback_jsont ~dec:(fun v ->
239
-
Hook_callback v)
240
-
in
241
-
let case_mcp_message =
242
-
Jsont.Object.Case.map "mcp_message" mcp_message_jsont ~dec:(fun v ->
243
-
Mcp_message v)
244
-
in
245
-
let case_set_model =
246
-
Jsont.Object.Case.map "set_model" set_model_jsont ~dec:(fun v ->
247
-
Set_model v)
248
-
in
249
-
let case_get_server_info =
250
-
Jsont.Object.Case.map "get_server_info" get_server_info_jsont
251
-
~dec:(fun v -> Get_server_info v)
252
-
in
253
-
254
-
let enc_case = function
255
-
| Interrupt v -> Jsont.Object.Case.value case_interrupt v
256
-
| Permission v -> Jsont.Object.Case.value case_permission v
257
-
| Initialize v -> Jsont.Object.Case.value case_initialize v
258
-
| Set_permission_mode v ->
259
-
Jsont.Object.Case.value case_set_permission_mode v
260
-
| Hook_callback v -> Jsont.Object.Case.value case_hook_callback v
261
-
| Mcp_message v -> Jsont.Object.Case.value case_mcp_message v
262
-
| Set_model v -> Jsont.Object.Case.value case_set_model v
263
-
| Get_server_info v -> Jsont.Object.Case.value case_get_server_info v
264
-
in
265
-
266
-
let cases =
267
-
Jsont.Object.Case.
268
-
[
269
-
make case_interrupt;
270
-
make case_permission;
271
-
make case_initialize;
272
-
make case_set_permission_mode;
273
-
make case_hook_callback;
274
-
make case_mcp_message;
275
-
make case_set_model;
276
-
make case_get_server_info;
277
-
]
278
-
in
279
-
280
-
Jsont.Object.map ~kind:"Request" Fun.id
281
-
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
282
-
~tag_to_string:Fun.id ~tag_compare:String.compare
283
-
|> Jsont.Object.finish
284
-
end
285
-
286
-
module Response = struct
287
-
(* Re-export Error_code from Proto *)
288
-
module Error_code = Proto.Control.Response.Error_code
289
-
290
-
(* Structured error similar to JSON-RPC *)
291
-
type error_detail = { code : int; message : string; data : Jsont.json option }
292
-
293
-
let error_detail ~code ~message ?data () =
294
-
{ code = Error_code.to_int code; message; data }
295
-
296
-
let error_detail_jsont : error_detail Jsont.t =
297
-
let make code message data = { code; message; data } in
298
-
Jsont.Object.map ~kind:"ErrorDetail" make
299
-
|> Jsont.Object.mem "code" Jsont.int ~enc:(fun e -> e.code)
300
-
|> Jsont.Object.mem "message" Jsont.string ~enc:(fun e -> e.message)
301
-
|> Jsont.Object.opt_mem "data" Jsont.json ~enc:(fun e -> e.data)
302
-
|> Jsont.Object.finish
303
-
304
-
type success = {
305
-
subtype : [ `Success ];
306
-
request_id : string;
307
-
response : Jsont.json option;
308
-
unknown : Unknown.t;
309
-
}
310
-
311
-
type error = {
312
-
subtype : [ `Error ];
313
-
request_id : string;
314
-
error : error_detail;
315
-
unknown : Unknown.t;
316
-
}
317
-
318
-
type t = Success of success | Error of error
319
-
320
-
let success ~request_id ?response ?(unknown = Unknown.empty) () =
321
-
Success { subtype = `Success; request_id; response; unknown }
322
-
323
-
let error ~request_id ~error ?(unknown = Unknown.empty) () =
324
-
Error { subtype = `Error; request_id; error; unknown }
325
-
326
-
(* Individual record codecs *)
327
-
let success_jsont : success Jsont.t =
328
-
let make request_id response (unknown : Unknown.t) : success =
329
-
{ subtype = `Success; request_id; response; unknown }
330
-
in
331
-
Jsont.Object.map ~kind:"Success" make
332
-
|> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun (r : success) ->
333
-
r.request_id)
334
-
|> Jsont.Object.opt_mem "response" Jsont.json ~enc:(fun (r : success) ->
335
-
r.response)
336
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : success) ->
337
-
r.unknown)
338
-
|> Jsont.Object.finish
339
-
340
-
let error_jsont : error Jsont.t =
341
-
let make request_id error (unknown : Unknown.t) : error =
342
-
{ subtype = `Error; request_id; error; unknown }
343
-
in
344
-
Jsont.Object.map ~kind:"Error" make
345
-
|> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun (r : error) ->
346
-
r.request_id)
347
-
|> Jsont.Object.mem "error" error_detail_jsont ~enc:(fun (r : error) ->
348
-
r.error)
349
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : error) ->
350
-
r.unknown)
351
-
|> Jsont.Object.finish
352
-
353
-
(* Main variant codec using subtype discriminator *)
354
-
let jsont : t Jsont.t =
355
-
let case_success =
356
-
Jsont.Object.Case.map "success" success_jsont ~dec:(fun v -> Success v)
357
-
in
358
-
let case_error =
359
-
Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
360
-
in
361
-
362
-
let enc_case = function
363
-
| Success v -> Jsont.Object.Case.value case_success v
364
-
| Error v -> Jsont.Object.Case.value case_error v
365
-
in
366
-
367
-
let cases = Jsont.Object.Case.[ make case_success; make case_error ] in
368
-
369
-
Jsont.Object.map ~kind:"Response" Fun.id
370
-
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
371
-
~tag_to_string:Fun.id ~tag_compare:String.compare
372
-
|> Jsont.Object.finish
373
-
end
374
-
375
-
type control_request = {
376
-
type_ : [ `Control_request ];
377
-
request_id : string;
378
-
request : Request.t;
379
-
unknown : Unknown.t;
380
-
}
381
-
382
-
type control_response = {
383
-
type_ : [ `Control_response ];
384
-
response : Response.t;
385
-
unknown : Unknown.t;
386
-
}
387
-
388
-
type t = Request of control_request | Response of control_response
389
-
390
-
let create_request ~request_id ~request ?(unknown = Unknown.empty) () =
391
-
Request { type_ = `Control_request; request_id; request; unknown }
392
-
393
-
let create_response ~response ?(unknown = Unknown.empty) () =
394
-
Response { type_ = `Control_response; response; unknown }
395
-
396
-
(* Individual record codecs *)
397
-
let control_request_jsont : control_request Jsont.t =
398
-
let make request_id request (unknown : Unknown.t) : control_request =
399
-
{ type_ = `Control_request; request_id; request; unknown }
400
-
in
401
-
Jsont.Object.map ~kind:"ControlRequest" make
402
-
|> Jsont.Object.mem "request_id" Jsont.string
403
-
~enc:(fun (r : control_request) -> r.request_id)
404
-
|> Jsont.Object.mem "request" Request.jsont ~enc:(fun (r : control_request) ->
405
-
r.request)
406
-
|> Jsont.Object.keep_unknown Jsont.json_mems
407
-
~enc:(fun (r : control_request) -> r.unknown)
408
-
|> Jsont.Object.finish
409
-
410
-
let control_response_jsont : control_response Jsont.t =
411
-
let make response (unknown : Unknown.t) : control_response =
412
-
{ type_ = `Control_response; response; unknown }
413
-
in
414
-
Jsont.Object.map ~kind:"ControlResponse" make
415
-
|> Jsont.Object.mem "response" Response.jsont
416
-
~enc:(fun (r : control_response) -> r.response)
417
-
|> Jsont.Object.keep_unknown Jsont.json_mems
418
-
~enc:(fun (r : control_response) -> r.unknown)
419
-
|> Jsont.Object.finish
420
-
421
-
(* Main variant codec using type discriminator *)
422
-
let jsont : t Jsont.t =
423
-
let case_request =
424
-
Jsont.Object.Case.map "control_request" control_request_jsont ~dec:(fun v ->
425
-
Request v)
426
-
in
427
-
let case_response =
428
-
Jsont.Object.Case.map "control_response" control_response_jsont
429
-
~dec:(fun v -> Response v)
430
-
in
431
-
432
-
let enc_case = function
433
-
| Request v -> Jsont.Object.Case.value case_request v
434
-
| Response v -> Jsont.Object.Case.value case_response v
435
-
in
436
-
437
-
let cases = Jsont.Object.Case.[ make case_request; make case_response ] in
438
-
439
-
Jsont.Object.map ~kind:"Control" Fun.id
440
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
441
-
~tag_to_string:Fun.id ~tag_compare:String.compare
442
-
|> Jsont.Object.finish
443
-
444
-
let log_request req =
445
-
Log.debug (fun m ->
446
-
m "SDK control request: %a" (Jsont.pp_value Request.jsont ()) req)
447
-
448
-
let log_response resp =
449
-
Log.debug (fun m ->
450
-
m "SDK control response: %a" (Jsont.pp_value Response.jsont ()) resp)
451
-
452
-
(** Server information *)
453
-
module Server_info = struct
454
-
type t = {
455
-
version : string;
456
-
capabilities : string list;
457
-
commands : string list;
458
-
output_styles : string list;
459
-
unknown : Unknown.t;
460
-
}
461
-
462
-
let create ~version ~capabilities ~commands ~output_styles
463
-
?(unknown = Unknown.empty) () =
464
-
{ version; capabilities; commands; output_styles; unknown }
465
-
466
-
let version t = t.version
467
-
let capabilities t = t.capabilities
468
-
let commands t = t.commands
469
-
let output_styles t = t.output_styles
470
-
let unknown t = t.unknown
471
-
472
-
let jsont : t Jsont.t =
473
-
let make version capabilities commands output_styles (unknown : Unknown.t) :
474
-
t =
475
-
{ version; capabilities; commands; output_styles; unknown }
476
-
in
477
-
Jsont.Object.map ~kind:"ServerInfo" make
478
-
|> Jsont.Object.mem "version" Jsont.string ~enc:(fun (r : t) -> r.version)
479
-
|> Jsont.Object.mem "capabilities" (Jsont.list Jsont.string)
480
-
~enc:(fun (r : t) -> r.capabilities)
481
-
~dec_absent:[]
482
-
|> Jsont.Object.mem "commands" (Jsont.list Jsont.string)
483
-
~enc:(fun (r : t) -> r.commands)
484
-
~dec_absent:[]
485
-
|> Jsont.Object.mem "outputStyles" (Jsont.list Jsont.string)
486
-
~enc:(fun (r : t) -> r.output_styles)
487
-
~dec_absent:[]
488
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : t) -> r.unknown)
489
-
|> Jsont.Object.finish
490
-
end
-369
lib/sdk_control.mli
-369
lib/sdk_control.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** SDK Control Protocol for Claude.
7
-
8
-
This module defines the typed SDK control protocol for bidirectional
9
-
communication between the SDK and the Claude CLI. It handles:
10
-
11
-
- Permission requests (tool usage authorization)
12
-
- Hook callbacks (intercepting and modifying tool execution)
13
-
- Dynamic control (changing settings mid-conversation)
14
-
- Server introspection (querying capabilities)
15
-
16
-
{2 Protocol Overview}
17
-
18
-
The SDK control protocol is a JSON-based request/response protocol that runs
19
-
alongside the main message stream. It enables:
20
-
21
-
1. {b Callbacks}: Claude asks the SDK for permission or hook execution 2.
22
-
{b Control}: SDK changes Claude's behavior dynamically 3. {b Introspection}:
23
-
SDK queries server metadata
24
-
25
-
{2 Request/Response Flow}
26
-
27
-
{v
28
-
SDK Claude CLI
29
-
| |
30
-
|-- Initialize (with hooks) --> |
31
-
|<-- Permission Request --------| (for tool usage)
32
-
|-- Allow/Deny Response ------> |
33
-
| |
34
-
|<-- Hook Callback -------------| (pre/post tool)
35
-
|-- Hook Result -------------> |
36
-
| |
37
-
|-- Set Model ---------------> | (dynamic control)
38
-
|<-- Success Response ----------|
39
-
| |
40
-
|-- Get Server Info ----------> |
41
-
|<-- Server Info Response ------|
42
-
v}
43
-
44
-
{2 Usage}
45
-
46
-
Most users won't interact with this module directly. The {!Client} module
47
-
handles the protocol automatically. However, this module is exposed for:
48
-
49
-
- Understanding the control protocol
50
-
- Implementing custom control logic
51
-
- Debugging control message flow
52
-
- Advanced SDK extensions
53
-
54
-
{2 Dynamic Control Examples}
55
-
56
-
See {!Client.set_permission_mode}, {!Client.set_model}, and
57
-
{!Client.get_server_info} for high-level APIs that use this protocol. *)
58
-
59
-
val src : Logs.Src.t
60
-
(** The log source for SDK control operations *)
61
-
62
-
(** {1 Request Types} *)
63
-
64
-
module Request : sig
65
-
(** SDK control request types. *)
66
-
67
-
type interrupt = { subtype : [ `Interrupt ]; unknown : Unknown.t }
68
-
(** Interrupt request to stop execution. *)
69
-
70
-
type permission = {
71
-
subtype : [ `Can_use_tool ];
72
-
tool_name : string;
73
-
input : Jsont.json;
74
-
permission_suggestions : Proto.Permissions.Update.t list option;
75
-
blocked_path : string option;
76
-
unknown : Unknown.t;
77
-
}
78
-
(** Permission request for tool usage. *)
79
-
80
-
type initialize = {
81
-
subtype : [ `Initialize ];
82
-
hooks : (string * Jsont.json) list option; (* Hook event to configuration *)
83
-
unknown : Unknown.t;
84
-
}
85
-
(** Initialize request with optional hook configuration. *)
86
-
87
-
type set_permission_mode = {
88
-
subtype : [ `Set_permission_mode ];
89
-
mode : Proto.Permissions.Mode.t;
90
-
unknown : Unknown.t;
91
-
}
92
-
(** Request to change permission mode. *)
93
-
94
-
type hook_callback = {
95
-
subtype : [ `Hook_callback ];
96
-
callback_id : string;
97
-
input : Jsont.json;
98
-
tool_use_id : string option;
99
-
unknown : Unknown.t;
100
-
}
101
-
(** Hook callback request. *)
102
-
103
-
type mcp_message = {
104
-
subtype : [ `Mcp_message ];
105
-
server_name : string;
106
-
message : Jsont.json;
107
-
unknown : Unknown.t;
108
-
}
109
-
(** MCP server message request. *)
110
-
111
-
type set_model = {
112
-
subtype : [ `Set_model ];
113
-
model : string;
114
-
unknown : Unknown.t;
115
-
}
116
-
(** Request to change the AI model. *)
117
-
118
-
type get_server_info = { subtype : [ `Get_server_info ]; unknown : Unknown.t }
119
-
(** Request to get server information. *)
120
-
121
-
type t =
122
-
| Interrupt of interrupt
123
-
| Permission of permission
124
-
| Initialize of initialize
125
-
| Set_permission_mode of set_permission_mode
126
-
| Hook_callback of hook_callback
127
-
| Mcp_message of mcp_message
128
-
| Set_model of set_model
129
-
| Get_server_info of get_server_info
130
-
(** The type of SDK control requests. *)
131
-
132
-
val interrupt : ?unknown:Unknown.t -> unit -> t
133
-
(** [interrupt ?unknown ()] creates an interrupt request. *)
134
-
135
-
val permission :
136
-
tool_name:string ->
137
-
input:Jsont.json ->
138
-
?permission_suggestions:Proto.Permissions.Update.t list ->
139
-
?blocked_path:string ->
140
-
?unknown:Unknown.t ->
141
-
unit ->
142
-
t
143
-
(** [permission ~tool_name ~input ?permission_suggestions ?blocked_path
144
-
?unknown ()] creates a permission request. *)
145
-
146
-
val initialize :
147
-
?hooks:(string * Jsont.json) list -> ?unknown:Unknown.t -> unit -> t
148
-
(** [initialize ?hooks ?unknown ()] creates an initialize request. *)
149
-
150
-
val set_permission_mode :
151
-
mode:Proto.Permissions.Mode.t -> ?unknown:Unknown.t -> unit -> t
152
-
(** [set_permission_mode ~mode ?unknown] creates a permission mode change
153
-
request. *)
154
-
155
-
val hook_callback :
156
-
callback_id:string ->
157
-
input:Jsont.json ->
158
-
?tool_use_id:string ->
159
-
?unknown:Unknown.t ->
160
-
unit ->
161
-
t
162
-
(** [hook_callback ~callback_id ~input ?tool_use_id ?unknown ()] creates a
163
-
hook callback request. *)
164
-
165
-
val mcp_message :
166
-
server_name:string -> message:Jsont.json -> ?unknown:Unknown.t -> unit -> t
167
-
(** [mcp_message ~server_name ~message ?unknown] creates an MCP message
168
-
request. *)
169
-
170
-
val set_model : model:string -> ?unknown:Unknown.t -> unit -> t
171
-
(** [set_model ~model ?unknown] creates a model change request. *)
172
-
173
-
val get_server_info : ?unknown:Unknown.t -> unit -> t
174
-
(** [get_server_info ?unknown ()] creates a server info request. *)
175
-
176
-
val jsont : t Jsont.t
177
-
(** [jsont] is the jsont codec for requests. Use [Jsont.pp_value jsont ()] for
178
-
pretty-printing. *)
179
-
end
180
-
181
-
(** {1 Response Types} *)
182
-
183
-
module Response : sig
184
-
(** SDK control response types. *)
185
-
186
-
module Error_code = Proto.Control.Response.Error_code
187
-
(** Re-export Error_code from Proto for convenience. *)
188
-
189
-
type error_detail = {
190
-
code : int; (** Error code for programmatic handling *)
191
-
message : string; (** Human-readable error message *)
192
-
data : Jsont.json option; (** Optional additional error data *)
193
-
}
194
-
(** Structured error detail similar to JSON-RPC.
195
-
196
-
This allows programmatic error handling with numeric error codes and
197
-
optional structured data for additional context. *)
198
-
199
-
val error_detail :
200
-
code:[< Error_code.t ] ->
201
-
message:string ->
202
-
?data:Jsont.json ->
203
-
unit ->
204
-
error_detail
205
-
(** [error_detail ~code ~message ?data ()] creates a structured error detail
206
-
using typed error codes.
207
-
208
-
Example:
209
-
{[
210
-
error_detail ~code:`Method_not_found ~message:"Hook callback not found"
211
-
()
212
-
]} *)
213
-
214
-
val error_detail_jsont : error_detail Jsont.t
215
-
(** [error_detail_jsont] is the Jsont codec for error details. *)
216
-
217
-
type success = {
218
-
subtype : [ `Success ];
219
-
request_id : string;
220
-
response : Jsont.json option;
221
-
unknown : Unknown.t;
222
-
}
223
-
(** Successful response. *)
224
-
225
-
type error = {
226
-
subtype : [ `Error ];
227
-
request_id : string;
228
-
error : error_detail;
229
-
unknown : Unknown.t;
230
-
}
231
-
(** Error response with structured error detail. *)
232
-
233
-
type t =
234
-
| Success of success
235
-
| Error of error (** The type of SDK control responses. *)
236
-
237
-
val success :
238
-
request_id:string -> ?response:Jsont.json -> ?unknown:Unknown.t -> unit -> t
239
-
(** [success ~request_id ?response ?unknown ()] creates a success response. *)
240
-
241
-
val error :
242
-
request_id:string -> error:error_detail -> ?unknown:Unknown.t -> unit -> t
243
-
(** [error ~request_id ~error ?unknown] creates an error response with
244
-
structured error detail. *)
245
-
246
-
val jsont : t Jsont.t
247
-
(** [jsont] is the jsont codec for responses. Use [Jsont.pp_value jsont ()]
248
-
for pretty-printing. *)
249
-
end
250
-
251
-
(** {1 Control Messages} *)
252
-
253
-
type control_request = {
254
-
type_ : [ `Control_request ];
255
-
request_id : string;
256
-
request : Request.t;
257
-
unknown : Unknown.t;
258
-
}
259
-
(** Control request message. *)
260
-
261
-
type control_response = {
262
-
type_ : [ `Control_response ];
263
-
response : Response.t;
264
-
unknown : Unknown.t;
265
-
}
266
-
(** Control response message. *)
267
-
268
-
val control_request_jsont : control_request Jsont.t
269
-
(** [control_request_jsont] is the jsont codec for control request messages. *)
270
-
271
-
val control_response_jsont : control_response Jsont.t
272
-
(** [control_response_jsont] is the jsont codec for control response messages.
273
-
*)
274
-
275
-
type t =
276
-
| Request of control_request
277
-
| Response of control_response (** The type of SDK control messages. *)
278
-
279
-
val create_request :
280
-
request_id:string -> request:Request.t -> ?unknown:Unknown.t -> unit -> t
281
-
(** [create_request ~request_id ~request ?unknown ()] creates a control request
282
-
message. *)
283
-
284
-
val create_response : response:Response.t -> ?unknown:Unknown.t -> unit -> t
285
-
(** [create_response ~response ?unknown ()] creates a control response message.
286
-
*)
287
-
288
-
val jsont : t Jsont.t
289
-
(** [jsont] is the jsont codec for control messages. Use
290
-
[Jsont.pp_value jsont ()] for pretty-printing. *)
291
-
292
-
(** {1 Logging} *)
293
-
294
-
val log_request : Request.t -> unit
295
-
(** [log_request req] logs an SDK control request. *)
296
-
297
-
val log_response : Response.t -> unit
298
-
(** [log_response resp] logs an SDK control response. *)
299
-
300
-
(** {1 Server Information}
301
-
302
-
Server information provides metadata about the Claude CLI server, including
303
-
version, capabilities, available commands, and output styles.
304
-
305
-
{2 Use Cases}
306
-
307
-
- Feature detection: Check if specific capabilities are available
308
-
- Version compatibility: Ensure minimum version requirements
309
-
- Debugging: Log server information for troubleshooting
310
-
- Dynamic adaptation: Adjust SDK behavior based on capabilities
311
-
312
-
{2 Example}
313
-
314
-
{[
315
-
let info = Client.get_server_info client in
316
-
Printf.printf "Claude CLI version: %s\n" (Server_info.version info);
317
-
318
-
if List.mem "structured-output" (Server_info.capabilities info) then
319
-
Printf.printf "Structured output is supported\n"
320
-
else Printf.printf "Structured output not available\n"
321
-
]} *)
322
-
323
-
module Server_info : sig
324
-
(** Server information and capabilities. *)
325
-
326
-
type t = {
327
-
version : string; (** Server version string (e.g., "2.0.0") *)
328
-
capabilities : string list;
329
-
(** Available server capabilities (e.g., "hooks", "structured-output")
330
-
*)
331
-
commands : string list; (** Available CLI commands *)
332
-
output_styles : string list;
333
-
(** Supported output formats (e.g., "json", "stream-json") *)
334
-
unknown : Unknown.t; (** Unknown fields for forward compatibility *)
335
-
}
336
-
(** Server metadata and capabilities.
337
-
338
-
This information is useful for feature detection and debugging. *)
339
-
340
-
val create :
341
-
version:string ->
342
-
capabilities:string list ->
343
-
commands:string list ->
344
-
output_styles:string list ->
345
-
?unknown:Unknown.t ->
346
-
unit ->
347
-
t
348
-
(** [create ~version ~capabilities ~commands ~output_styles ?unknown ()]
349
-
creates server info. *)
350
-
351
-
val version : t -> string
352
-
(** [version t] returns the server version. *)
353
-
354
-
val capabilities : t -> string list
355
-
(** [capabilities t] returns the server capabilities. *)
356
-
357
-
val commands : t -> string list
358
-
(** [commands t] returns available commands. *)
359
-
360
-
val output_styles : t -> string list
361
-
(** [output_styles t] returns available output styles. *)
362
-
363
-
val unknown : t -> Unknown.t
364
-
(** [unknown t] returns the unknown fields. *)
365
-
366
-
val jsont : t Jsont.t
367
-
(** [jsont] is the jsont codec for server info. Use [Jsont.pp_value jsont ()]
368
-
for pretty-printing. *)
369
-
end
lib/server_info.cmi
lib/server_info.cmi
This is a binary file and will not be displayed.
-141
proto/content_block.ml
-141
proto/content_block.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module Text = struct
7
-
type t = { text : string; unknown : Unknown.t }
8
-
9
-
let create text = { text; unknown = Unknown.empty }
10
-
let make text unknown = { text; unknown }
11
-
let text t = t.text
12
-
let unknown t = t.unknown
13
-
14
-
let jsont : t Jsont.t =
15
-
Jsont.Object.map ~kind:"Text" make
16
-
|> Jsont.Object.mem "text" Jsont.string ~enc:text
17
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
18
-
|> Jsont.Object.finish
19
-
end
20
-
21
-
module Tool_use = struct
22
-
type t = {
23
-
id : string;
24
-
name : string;
25
-
input : Jsont.json;
26
-
unknown : Unknown.t;
27
-
}
28
-
29
-
let create ~id ~name ~input = { id; name; input; unknown = Unknown.empty }
30
-
let make id name input unknown = { id; name; input; unknown }
31
-
let id t = t.id
32
-
let name t = t.name
33
-
let input t = t.input
34
-
let unknown t = t.unknown
35
-
36
-
let jsont : t Jsont.t =
37
-
Jsont.Object.map ~kind:"Tool_use" make
38
-
|> Jsont.Object.mem "id" Jsont.string ~enc:id
39
-
|> Jsont.Object.mem "name" Jsont.string ~enc:name
40
-
|> Jsont.Object.mem "input" Jsont.json ~enc:input
41
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
42
-
|> Jsont.Object.finish
43
-
end
44
-
45
-
module Tool_result = struct
46
-
type t = {
47
-
tool_use_id : string;
48
-
content : Jsont.json option;
49
-
is_error : bool option;
50
-
unknown : Unknown.t;
51
-
}
52
-
53
-
let create ~tool_use_id ?content ?is_error () =
54
-
{ tool_use_id; content; is_error; unknown = Unknown.empty }
55
-
56
-
let make tool_use_id content is_error unknown =
57
-
{ tool_use_id; content; is_error; unknown }
58
-
59
-
let tool_use_id t = t.tool_use_id
60
-
let content t = t.content
61
-
let is_error t = t.is_error
62
-
let unknown t = t.unknown
63
-
64
-
let jsont : t Jsont.t =
65
-
Jsont.Object.map ~kind:"Tool_result" make
66
-
|> Jsont.Object.mem "tool_use_id" Jsont.string ~enc:tool_use_id
67
-
|> Jsont.Object.opt_mem "content" Jsont.json ~enc:content
68
-
|> Jsont.Object.opt_mem "is_error" Jsont.bool ~enc:is_error
69
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
70
-
|> Jsont.Object.finish
71
-
end
72
-
73
-
module Thinking = struct
74
-
type t = { thinking : string; signature : string; unknown : Unknown.t }
75
-
76
-
let create ~thinking ~signature =
77
-
{ thinking; signature; unknown = Unknown.empty }
78
-
79
-
let make thinking signature unknown = { thinking; signature; unknown }
80
-
let thinking t = t.thinking
81
-
let signature t = t.signature
82
-
let unknown t = t.unknown
83
-
84
-
let jsont : t Jsont.t =
85
-
Jsont.Object.map ~kind:"Thinking" make
86
-
|> Jsont.Object.mem "thinking" Jsont.string ~enc:thinking
87
-
|> Jsont.Object.mem "signature" Jsont.string ~enc:signature
88
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
89
-
|> Jsont.Object.finish
90
-
end
91
-
92
-
type t =
93
-
| Text of Text.t
94
-
| Tool_use of Tool_use.t
95
-
| Tool_result of Tool_result.t
96
-
| Thinking of Thinking.t
97
-
98
-
let text s = Text (Text.create s)
99
-
let tool_use ~id ~name ~input = Tool_use (Tool_use.create ~id ~name ~input)
100
-
101
-
let tool_result ~tool_use_id ?content ?is_error () =
102
-
Tool_result (Tool_result.create ~tool_use_id ?content ?is_error ())
103
-
104
-
let thinking ~thinking ~signature =
105
-
Thinking (Thinking.create ~thinking ~signature)
106
-
107
-
let jsont : t Jsont.t =
108
-
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
109
-
110
-
let case_text = case_map "text" Text.jsont (fun v -> Text v) in
111
-
let case_tool_use =
112
-
case_map "tool_use" Tool_use.jsont (fun v -> Tool_use v)
113
-
in
114
-
let case_tool_result =
115
-
case_map "tool_result" Tool_result.jsont (fun v -> Tool_result v)
116
-
in
117
-
let case_thinking =
118
-
case_map "thinking" Thinking.jsont (fun v -> Thinking v)
119
-
in
120
-
121
-
let enc_case = function
122
-
| Text v -> Jsont.Object.Case.value case_text v
123
-
| Tool_use v -> Jsont.Object.Case.value case_tool_use v
124
-
| Tool_result v -> Jsont.Object.Case.value case_tool_result v
125
-
| Thinking v -> Jsont.Object.Case.value case_thinking v
126
-
in
127
-
128
-
let cases =
129
-
Jsont.Object.Case.
130
-
[
131
-
make case_text;
132
-
make case_tool_use;
133
-
make case_tool_result;
134
-
make case_thinking;
135
-
]
136
-
in
137
-
138
-
Jsont.Object.map ~kind:"Content_block" Fun.id
139
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
140
-
~tag_to_string:Fun.id ~tag_compare:String.compare
141
-
|> 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
-157
proto/content_block.mli
-157
proto/content_block.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Content blocks for Claude messages wire format.
7
-
8
-
This module defines the wire format types for content blocks that can appear
9
-
in Claude messages, including text, tool use, tool results, and thinking
10
-
blocks. *)
11
-
12
-
(** {1 Text Blocks} *)
13
-
14
-
module Text : sig
15
-
(** Plain text content blocks. *)
16
-
17
-
type t
18
-
(** The type of text blocks. *)
19
-
20
-
val jsont : t Jsont.t
21
-
(** [jsont] is the Jsont codec for text blocks. Use [Jsont.Json.encode jsont]
22
-
and [Jsont.Json.decode jsont] for serialization. Use
23
-
[Jsont.pp_value jsont ()] for pretty-printing. *)
24
-
25
-
val create : string -> t
26
-
(** [create text] creates a new text block with the given text content. *)
27
-
28
-
val text : t -> string
29
-
(** [text t] returns the text content of the block. *)
30
-
31
-
val unknown : t -> Unknown.t
32
-
(** [unknown t] returns any unknown fields from JSON parsing. *)
33
-
end
34
-
35
-
(** {1 Tool Use Blocks} *)
36
-
37
-
module Tool_use : sig
38
-
(** Tool invocation requests from the assistant. *)
39
-
40
-
type t
41
-
(** The type of tool use blocks. *)
42
-
43
-
val jsont : t Jsont.t
44
-
(** [jsont] is the Jsont codec for tool use blocks. Use
45
-
[Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
46
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
47
-
48
-
val create : id:string -> name:string -> input:Jsont.json -> t
49
-
(** [create ~id ~name ~input] creates a new tool use block.
50
-
@param id Unique identifier for this tool invocation
51
-
@param name Name of the tool to invoke
52
-
@param input Parameters for the tool as raw JSON *)
53
-
54
-
val id : t -> string
55
-
(** [id t] returns the unique identifier of the tool use. *)
56
-
57
-
val name : t -> string
58
-
(** [name t] returns the name of the tool being invoked. *)
59
-
60
-
val input : t -> Jsont.json
61
-
(** [input t] returns the input parameters for the tool as raw JSON. *)
62
-
63
-
val unknown : t -> Unknown.t
64
-
(** [unknown t] returns any unknown fields from JSON parsing. *)
65
-
end
66
-
67
-
(** {1 Tool Result Blocks} *)
68
-
69
-
module Tool_result : sig
70
-
(** Results from tool invocations. *)
71
-
72
-
type t
73
-
(** The type of tool result blocks. *)
74
-
75
-
val jsont : t Jsont.t
76
-
(** [jsont] is the Jsont codec for tool result blocks. Use
77
-
[Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
78
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
79
-
80
-
val create :
81
-
tool_use_id:string -> ?content:Jsont.json -> ?is_error:bool -> unit -> t
82
-
(** [create ~tool_use_id ?content ?is_error ()] creates a new tool result
83
-
block.
84
-
@param tool_use_id The ID of the corresponding tool use block
85
-
@param content
86
-
Optional result content (can be string or array of content blocks)
87
-
@param is_error Whether the tool execution resulted in an error *)
88
-
89
-
val tool_use_id : t -> string
90
-
(** [tool_use_id t] returns the ID of the corresponding tool use. *)
91
-
92
-
val content : t -> Jsont.json option
93
-
(** [content t] returns the optional result content as raw JSON. *)
94
-
95
-
val is_error : t -> bool option
96
-
(** [is_error t] returns whether this result represents an error. *)
97
-
98
-
val unknown : t -> Unknown.t
99
-
(** [unknown t] returns any unknown fields from JSON parsing. *)
100
-
end
101
-
102
-
(** {1 Thinking Blocks} *)
103
-
104
-
module Thinking : sig
105
-
(** Assistant's internal reasoning blocks. *)
106
-
107
-
type t
108
-
(** The type of thinking blocks. *)
109
-
110
-
val jsont : t Jsont.t
111
-
(** [jsont] is the Jsont codec for thinking blocks. Use
112
-
[Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization.
113
-
Use [Jsont.pp_value jsont ()] for pretty-printing. *)
114
-
115
-
val create : thinking:string -> signature:string -> t
116
-
(** [create ~thinking ~signature] creates a new thinking block.
117
-
@param thinking The assistant's internal reasoning
118
-
@param signature Cryptographic signature for verification *)
119
-
120
-
val thinking : t -> string
121
-
(** [thinking t] returns the thinking content. *)
122
-
123
-
val signature : t -> string
124
-
(** [signature t] returns the cryptographic signature. *)
125
-
126
-
val unknown : t -> Unknown.t
127
-
(** [unknown t] returns any unknown fields from JSON parsing. *)
128
-
end
129
-
130
-
(** {1 Content Block Union Type} *)
131
-
132
-
type t =
133
-
| Text of Text.t
134
-
| Tool_use of Tool_use.t
135
-
| Tool_result of Tool_result.t
136
-
| Thinking of Thinking.t
137
-
(** The type of content blocks, which can be text, tool use, tool result,
138
-
or thinking. *)
139
-
140
-
val jsont : t Jsont.t
141
-
(** [jsont] is the Jsont codec for content blocks. Use [Jsont.Json.encode jsont]
142
-
and [Jsont.Json.decode jsont] for serialization. Use
143
-
[Jsont.pp_value jsont ()] for pretty-printing. *)
144
-
145
-
val text : string -> t
146
-
(** [text s] creates a text content block. *)
147
-
148
-
val tool_use : id:string -> name:string -> input:Jsont.json -> t
149
-
(** [tool_use ~id ~name ~input] creates a tool use content block. *)
150
-
151
-
val tool_result :
152
-
tool_use_id:string -> ?content:Jsont.json -> ?is_error:bool -> unit -> t
153
-
(** [tool_result ~tool_use_id ?content ?is_error ()] creates a tool result
154
-
content block. Content can be a string or an array of content blocks. *)
155
-
156
-
val thinking : thinking:string -> signature:string -> t
157
-
(** [thinking ~thinking ~signature] creates a thinking content block. *)
-416
proto/control.ml
-416
proto/control.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Control protocol wire format for SDK communication. *)
7
-
8
-
module Request = struct
9
-
(* Individual record types for each request variant - private to this module *)
10
-
type permission_r = {
11
-
tool_name : string;
12
-
input : Jsont.json;
13
-
permission_suggestions : Permissions.Update.t list option;
14
-
blocked_path : string option;
15
-
unknown : Unknown.t;
16
-
}
17
-
18
-
type initialize_r = {
19
-
hooks : (string * Jsont.json) list option;
20
-
unknown : Unknown.t;
21
-
}
22
-
23
-
type set_permission_mode_r = {
24
-
mode : Permissions.Mode.t;
25
-
unknown : Unknown.t;
26
-
}
27
-
28
-
type hook_callback_r = {
29
-
callback_id : string;
30
-
input : Jsont.json;
31
-
tool_use_id : string option;
32
-
unknown : Unknown.t;
33
-
}
34
-
35
-
type mcp_message_r = {
36
-
server_name : string;
37
-
message : Jsont.json;
38
-
unknown : Unknown.t;
39
-
}
40
-
41
-
type set_model_r = { model : string; unknown : Unknown.t }
42
-
43
-
type t =
44
-
| Interrupt
45
-
| Permission of permission_r
46
-
| Initialize of initialize_r
47
-
| Set_permission_mode of set_permission_mode_r
48
-
| Hook_callback of hook_callback_r
49
-
| Mcp_message of mcp_message_r
50
-
| Set_model of set_model_r
51
-
| Get_server_info
52
-
53
-
let interrupt () = Interrupt
54
-
55
-
let permission ~tool_name ~input ?permission_suggestions ?blocked_path () =
56
-
Permission
57
-
{
58
-
tool_name;
59
-
input;
60
-
permission_suggestions;
61
-
blocked_path;
62
-
unknown = Unknown.empty;
63
-
}
64
-
65
-
let initialize ?hooks () = Initialize { hooks; unknown = Unknown.empty }
66
-
67
-
let set_permission_mode ~mode () =
68
-
Set_permission_mode { mode; unknown = Unknown.empty }
69
-
70
-
let hook_callback ~callback_id ~input ?tool_use_id () =
71
-
Hook_callback { callback_id; input; tool_use_id; unknown = Unknown.empty }
72
-
73
-
let mcp_message ~server_name ~message () =
74
-
Mcp_message { server_name; message; unknown = Unknown.empty }
75
-
76
-
let set_model ~model () = Set_model { model; unknown = Unknown.empty }
77
-
let get_server_info () = Get_server_info
78
-
79
-
(* Individual record codecs *)
80
-
let interrupt_jsont : unit Jsont.t =
81
-
Jsont.Object.map ~kind:"Interrupt" (fun _unknown -> ())
82
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun () -> Unknown.empty)
83
-
|> Jsont.Object.finish
84
-
85
-
let permission_jsont : permission_r Jsont.t =
86
-
let make tool_name input permission_suggestions blocked_path unknown :
87
-
permission_r =
88
-
{ tool_name; input; permission_suggestions; blocked_path; unknown }
89
-
in
90
-
Jsont.Object.map ~kind:"Permission" make
91
-
|> Jsont.Object.mem "toolName" Jsont.string ~enc:(fun (r : permission_r) ->
92
-
r.tool_name)
93
-
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : permission_r) ->
94
-
r.input)
95
-
|> Jsont.Object.opt_mem "permissionSuggestions"
96
-
(Jsont.list Permissions.Update.jsont) ~enc:(fun (r : permission_r) ->
97
-
r.permission_suggestions)
98
-
|> Jsont.Object.opt_mem "blockedPath" Jsont.string
99
-
~enc:(fun (r : permission_r) -> r.blocked_path)
100
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : permission_r) ->
101
-
r.unknown)
102
-
|> Jsont.Object.finish
103
-
104
-
let initialize_jsont : initialize_r Jsont.t =
105
-
(* The hooks field is an object with string keys and json values *)
106
-
let hooks_map_jsont = Jsont.Object.as_string_map Jsont.json in
107
-
let module StringMap = Map.Make (String) in
108
-
let hooks_jsont =
109
-
Jsont.map
110
-
~dec:(fun m -> StringMap.bindings m)
111
-
~enc:(fun l -> StringMap.of_seq (List.to_seq l))
112
-
hooks_map_jsont
113
-
in
114
-
let make hooks unknown = { hooks; unknown } in
115
-
Jsont.Object.map ~kind:"Initialize" make
116
-
|> Jsont.Object.opt_mem "hooks" hooks_jsont ~enc:(fun (r : initialize_r) ->
117
-
r.hooks)
118
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : initialize_r) ->
119
-
r.unknown)
120
-
|> Jsont.Object.finish
121
-
122
-
let set_permission_mode_jsont : set_permission_mode_r Jsont.t =
123
-
let make mode unknown = { mode; unknown } in
124
-
Jsont.Object.map ~kind:"SetPermissionMode" make
125
-
|> Jsont.Object.mem "mode" Permissions.Mode.jsont
126
-
~enc:(fun (r : set_permission_mode_r) -> r.mode)
127
-
|> Jsont.Object.keep_unknown Unknown.mems
128
-
~enc:(fun (r : set_permission_mode_r) -> r.unknown)
129
-
|> Jsont.Object.finish
130
-
131
-
let hook_callback_jsont : hook_callback_r Jsont.t =
132
-
let make callback_id input tool_use_id unknown =
133
-
{ callback_id; input; tool_use_id; unknown }
134
-
in
135
-
Jsont.Object.map ~kind:"HookCallback" make
136
-
|> Jsont.Object.mem "callbackId" Jsont.string
137
-
~enc:(fun (r : hook_callback_r) -> r.callback_id)
138
-
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : hook_callback_r) ->
139
-
r.input)
140
-
|> Jsont.Object.opt_mem "toolUseId" Jsont.string
141
-
~enc:(fun (r : hook_callback_r) -> r.tool_use_id)
142
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : hook_callback_r) ->
143
-
r.unknown)
144
-
|> Jsont.Object.finish
145
-
146
-
let mcp_message_jsont : mcp_message_r Jsont.t =
147
-
let make server_name message unknown = { server_name; message; unknown } in
148
-
Jsont.Object.map ~kind:"McpMessage" make
149
-
|> Jsont.Object.mem "serverName" Jsont.string
150
-
~enc:(fun (r : mcp_message_r) -> r.server_name)
151
-
|> Jsont.Object.mem "message" Jsont.json ~enc:(fun (r : mcp_message_r) ->
152
-
r.message)
153
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : mcp_message_r) ->
154
-
r.unknown)
155
-
|> Jsont.Object.finish
156
-
157
-
let set_model_jsont : set_model_r Jsont.t =
158
-
let make model unknown = { model; unknown } in
159
-
Jsont.Object.map ~kind:"SetModel" make
160
-
|> Jsont.Object.mem "model" Jsont.string ~enc:(fun (r : set_model_r) ->
161
-
r.model)
162
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : set_model_r) ->
163
-
r.unknown)
164
-
|> Jsont.Object.finish
165
-
166
-
let get_server_info_jsont : unit Jsont.t =
167
-
Jsont.Object.map ~kind:"GetServerInfo" (fun _unknown -> ())
168
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun () -> Unknown.empty)
169
-
|> Jsont.Object.finish
170
-
171
-
(* Main variant codec using subtype discriminator *)
172
-
let jsont : t Jsont.t =
173
-
let case_interrupt =
174
-
Jsont.Object.Case.map "interrupt" interrupt_jsont ~dec:(fun () ->
175
-
Interrupt)
176
-
in
177
-
let case_permission =
178
-
Jsont.Object.Case.map "canUseTool" permission_jsont ~dec:(fun v ->
179
-
Permission v)
180
-
in
181
-
let case_initialize =
182
-
Jsont.Object.Case.map "initialize" initialize_jsont ~dec:(fun v ->
183
-
Initialize v)
184
-
in
185
-
let case_set_permission_mode =
186
-
Jsont.Object.Case.map "setPermissionMode" set_permission_mode_jsont
187
-
~dec:(fun v -> Set_permission_mode v)
188
-
in
189
-
let case_hook_callback =
190
-
Jsont.Object.Case.map "hookCallback" hook_callback_jsont ~dec:(fun v ->
191
-
Hook_callback v)
192
-
in
193
-
let case_mcp_message =
194
-
Jsont.Object.Case.map "mcpMessage" mcp_message_jsont ~dec:(fun v ->
195
-
Mcp_message v)
196
-
in
197
-
let case_set_model =
198
-
Jsont.Object.Case.map "setModel" set_model_jsont ~dec:(fun v ->
199
-
Set_model v)
200
-
in
201
-
let case_get_server_info =
202
-
Jsont.Object.Case.map "getServerInfo" get_server_info_jsont
203
-
~dec:(fun () -> Get_server_info)
204
-
in
205
-
206
-
let enc_case = function
207
-
| Interrupt -> Jsont.Object.Case.value case_interrupt ()
208
-
| Permission v -> Jsont.Object.Case.value case_permission v
209
-
| Initialize v -> Jsont.Object.Case.value case_initialize v
210
-
| Set_permission_mode v ->
211
-
Jsont.Object.Case.value case_set_permission_mode v
212
-
| Hook_callback v -> Jsont.Object.Case.value case_hook_callback v
213
-
| Mcp_message v -> Jsont.Object.Case.value case_mcp_message v
214
-
| Set_model v -> Jsont.Object.Case.value case_set_model v
215
-
| Get_server_info -> Jsont.Object.Case.value case_get_server_info ()
216
-
in
217
-
218
-
let cases =
219
-
Jsont.Object.Case.
220
-
[
221
-
make case_interrupt;
222
-
make case_permission;
223
-
make case_initialize;
224
-
make case_set_permission_mode;
225
-
make case_hook_callback;
226
-
make case_mcp_message;
227
-
make case_set_model;
228
-
make case_get_server_info;
229
-
]
230
-
in
231
-
232
-
Jsont.Object.map ~kind:"Request" Fun.id
233
-
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
234
-
~tag_to_string:Fun.id ~tag_compare:String.compare
235
-
|> Jsont.Object.finish
236
-
end
237
-
238
-
module Response = struct
239
-
(* Standard JSON-RPC 2.0 error codes using polymorphic variants *)
240
-
module Error_code = struct
241
-
type t =
242
-
[ `Parse_error
243
-
| `Invalid_request
244
-
| `Method_not_found
245
-
| `Invalid_params
246
-
| `Internal_error
247
-
| `Custom of int ]
248
-
249
-
let to_int : [< t ] -> int = function
250
-
| `Parse_error -> -32700
251
-
| `Invalid_request -> -32600
252
-
| `Method_not_found -> -32601
253
-
| `Invalid_params -> -32602
254
-
| `Internal_error -> -32603
255
-
| `Custom n -> n
256
-
257
-
let of_int = function
258
-
| -32700 -> `Parse_error
259
-
| -32600 -> `Invalid_request
260
-
| -32601 -> `Method_not_found
261
-
| -32602 -> `Invalid_params
262
-
| -32603 -> `Internal_error
263
-
| n -> `Custom n
264
-
end
265
-
266
-
(* Structured error similar to JSON-RPC *)
267
-
type error_detail = { code : int; message : string; data : Jsont.json option }
268
-
269
-
let error_detail ~code ~message ?data () =
270
-
{ code = Error_code.to_int code; message; data }
271
-
272
-
let error_detail_jsont : error_detail Jsont.t =
273
-
let make code message data = { code; message; data } in
274
-
Jsont.Object.map ~kind:"ErrorDetail" make
275
-
|> Jsont.Object.mem "code" Jsont.int ~enc:(fun e -> e.code)
276
-
|> Jsont.Object.mem "message" Jsont.string ~enc:(fun e -> e.message)
277
-
|> Jsont.Object.opt_mem "data" Jsont.json ~enc:(fun e -> e.data)
278
-
|> Jsont.Object.finish
279
-
280
-
(* Individual record types for each response variant *)
281
-
type success_r = {
282
-
request_id : string;
283
-
response : Jsont.json option;
284
-
unknown : Unknown.t;
285
-
}
286
-
287
-
type error_r = {
288
-
request_id : string;
289
-
error : error_detail;
290
-
unknown : Unknown.t;
291
-
}
292
-
293
-
type t = Success of success_r | Error of error_r
294
-
295
-
let success ~request_id ?response () =
296
-
Success { request_id; response; unknown = Unknown.empty }
297
-
298
-
let error ~request_id ~error () =
299
-
Error { request_id; error; unknown = Unknown.empty }
300
-
301
-
(* Individual record codecs *)
302
-
let success_jsont : success_r Jsont.t =
303
-
let make request_id response unknown = { request_id; response; unknown } in
304
-
Jsont.Object.map ~kind:"Success" make
305
-
|> Jsont.Object.mem "requestId" Jsont.string ~enc:(fun (r : success_r) ->
306
-
r.request_id)
307
-
|> Jsont.Object.opt_mem "response" Jsont.json ~enc:(fun (r : success_r) ->
308
-
r.response)
309
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : success_r) ->
310
-
r.unknown)
311
-
|> Jsont.Object.finish
312
-
313
-
let error_jsont : error_r Jsont.t =
314
-
let make request_id error unknown = { request_id; error; unknown } in
315
-
Jsont.Object.map ~kind:"Error" make
316
-
|> Jsont.Object.mem "requestId" Jsont.string ~enc:(fun (r : error_r) ->
317
-
r.request_id)
318
-
|> Jsont.Object.mem "error" error_detail_jsont ~enc:(fun (r : error_r) ->
319
-
r.error)
320
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : error_r) ->
321
-
r.unknown)
322
-
|> Jsont.Object.finish
323
-
324
-
(* Main variant codec using subtype discriminator *)
325
-
let jsont : t Jsont.t =
326
-
let case_success =
327
-
Jsont.Object.Case.map "success" success_jsont ~dec:(fun v -> Success v)
328
-
in
329
-
let case_error =
330
-
Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
331
-
in
332
-
333
-
let enc_case = function
334
-
| Success v -> Jsont.Object.Case.value case_success v
335
-
| Error v -> Jsont.Object.Case.value case_error v
336
-
in
337
-
338
-
let cases = Jsont.Object.Case.[ make case_success; make case_error ] in
339
-
340
-
Jsont.Object.map ~kind:"Response" Fun.id
341
-
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
342
-
~tag_to_string:Fun.id ~tag_compare:String.compare
343
-
|> Jsont.Object.finish
344
-
end
345
-
346
-
type request_envelope = {
347
-
request_id : string;
348
-
request : Request.t;
349
-
unknown : Unknown.t;
350
-
}
351
-
352
-
type response_envelope = { response : Response.t; unknown : Unknown.t }
353
-
354
-
let create_request ~request_id ~request () =
355
-
{ request_id; request; unknown = Unknown.empty }
356
-
357
-
let create_response ~response () = { response; unknown = Unknown.empty }
358
-
359
-
(* Envelope codecs *)
360
-
let request_envelope_jsont : request_envelope Jsont.t =
361
-
let make request_id request unknown = { request_id; request; unknown } in
362
-
Jsont.Object.map ~kind:"RequestEnvelope" make
363
-
|> Jsont.Object.mem "requestId" Jsont.string
364
-
~enc:(fun (r : request_envelope) -> r.request_id)
365
-
|> Jsont.Object.mem "request" Request.jsont
366
-
~enc:(fun (r : request_envelope) -> r.request)
367
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : request_envelope) ->
368
-
r.unknown)
369
-
|> Jsont.Object.finish
370
-
371
-
let response_envelope_jsont : response_envelope Jsont.t =
372
-
let make response unknown = { response; unknown } in
373
-
Jsont.Object.map ~kind:"ResponseEnvelope" make
374
-
|> Jsont.Object.mem "response" Response.jsont
375
-
~enc:(fun (r : response_envelope) -> r.response)
376
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : response_envelope) ->
377
-
r.unknown)
378
-
|> Jsont.Object.finish
379
-
380
-
(** Server information *)
381
-
module Server_info = struct
382
-
type t = {
383
-
version : string;
384
-
capabilities : string list;
385
-
commands : string list;
386
-
output_styles : string list;
387
-
unknown : Unknown.t;
388
-
}
389
-
390
-
let create ~version ~capabilities ~commands ~output_styles () =
391
-
{ version; capabilities; commands; output_styles; unknown = Unknown.empty }
392
-
393
-
let version t = t.version
394
-
let capabilities t = t.capabilities
395
-
let commands t = t.commands
396
-
let output_styles t = t.output_styles
397
-
let unknown t = t.unknown
398
-
399
-
let jsont : t Jsont.t =
400
-
let make version capabilities commands output_styles unknown =
401
-
{ version; capabilities; commands; output_styles; unknown }
402
-
in
403
-
Jsont.Object.map ~kind:"ServerInfo" make
404
-
|> Jsont.Object.mem "version" Jsont.string ~enc:(fun r -> r.version)
405
-
|> Jsont.Object.mem "capabilities" (Jsont.list Jsont.string)
406
-
~enc:(fun r -> r.capabilities)
407
-
~dec_absent:[]
408
-
|> Jsont.Object.mem "commands" (Jsont.list Jsont.string)
409
-
~enc:(fun r -> r.commands)
410
-
~dec_absent:[]
411
-
|> Jsont.Object.mem "outputStyles" (Jsont.list Jsont.string)
412
-
~enc:(fun r -> r.output_styles)
413
-
~dec_absent:[]
414
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun r -> r.unknown)
415
-
|> Jsont.Object.finish
416
-
end
-250
proto/control.mli
-250
proto/control.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Control protocol wire format for SDK communication.
7
-
8
-
This module defines the wire format for the SDK control protocol used for
9
-
bidirectional communication between the SDK and the Claude CLI. It handles
10
-
JSON serialization and deserialization of control messages.
11
-
12
-
The control protocol enables:
13
-
- Permission requests for tool usage authorization
14
-
- Hook callbacks for intercepting and modifying tool execution
15
-
- Dynamic control for changing settings mid-conversation
16
-
- Server introspection for querying capabilities *)
17
-
18
-
(** {1 Request Types} *)
19
-
20
-
module Request : sig
21
-
(** SDK control request types. *)
22
-
23
-
type permission_r = private {
24
-
tool_name : string;
25
-
input : Jsont.json;
26
-
permission_suggestions : Permissions.Update.t list option;
27
-
blocked_path : string option;
28
-
unknown : Unknown.t;
29
-
}
30
-
31
-
type initialize_r = private {
32
-
hooks : (string * Jsont.json) list option;
33
-
unknown : Unknown.t;
34
-
}
35
-
36
-
type set_permission_mode_r = private {
37
-
mode : Permissions.Mode.t;
38
-
unknown : Unknown.t;
39
-
}
40
-
41
-
type hook_callback_r = private {
42
-
callback_id : string;
43
-
input : Jsont.json;
44
-
tool_use_id : string option;
45
-
unknown : Unknown.t;
46
-
}
47
-
48
-
type mcp_message_r = private {
49
-
server_name : string;
50
-
message : Jsont.json;
51
-
unknown : Unknown.t;
52
-
}
53
-
54
-
type set_model_r = private { model : string; unknown : Unknown.t }
55
-
56
-
type t =
57
-
| Interrupt
58
-
| Permission of permission_r
59
-
| Initialize of initialize_r
60
-
| Set_permission_mode of set_permission_mode_r
61
-
| Hook_callback of hook_callback_r
62
-
| Mcp_message of mcp_message_r
63
-
| Set_model of set_model_r
64
-
| Get_server_info
65
-
(** The type of SDK control requests. Wire format uses "subtype" field:
66
-
"interrupt", "canUseTool", "initialize", "setPermissionMode",
67
-
"hookCallback", "mcpMessage", "setModel", "getServerInfo". *)
68
-
69
-
val jsont : t Jsont.t
70
-
(** [jsont] is the Jsont codec for requests. *)
71
-
72
-
val interrupt : unit -> t
73
-
(** [interrupt ()] creates an interrupt request. *)
74
-
75
-
val permission :
76
-
tool_name:string ->
77
-
input:Jsont.json ->
78
-
?permission_suggestions:Permissions.Update.t list ->
79
-
?blocked_path:string ->
80
-
unit ->
81
-
t
82
-
(** [permission ~tool_name ~input ?permission_suggestions ?blocked_path ()]
83
-
creates a permission request. *)
84
-
85
-
val initialize : ?hooks:(string * Jsont.json) list -> unit -> t
86
-
(** [initialize ?hooks ()] creates an initialize request. *)
87
-
88
-
val set_permission_mode : mode:Permissions.Mode.t -> unit -> t
89
-
(** [set_permission_mode ~mode ()] creates a permission mode change request.
90
-
*)
91
-
92
-
val hook_callback :
93
-
callback_id:string -> input:Jsont.json -> ?tool_use_id:string -> unit -> t
94
-
(** [hook_callback ~callback_id ~input ?tool_use_id ()] creates a hook
95
-
callback request. *)
96
-
97
-
val mcp_message : server_name:string -> message:Jsont.json -> unit -> t
98
-
(** [mcp_message ~server_name ~message ()] creates an MCP message request. *)
99
-
100
-
val set_model : model:string -> unit -> t
101
-
(** [set_model ~model ()] creates a model change request. *)
102
-
103
-
val get_server_info : unit -> t
104
-
(** [get_server_info ()] creates a server info request. *)
105
-
end
106
-
107
-
(** {1 Response Types} *)
108
-
109
-
module Response : sig
110
-
(** SDK control response types. *)
111
-
112
-
(** Standard JSON-RPC 2.0 error codes.
113
-
114
-
These codes follow the JSON-RPC 2.0 specification for structured error
115
-
responses. Using the typed codes instead of raw integers improves code
116
-
clarity and prevents typos. Polymorphic variants allow for easy extension.
117
-
*)
118
-
module Error_code : sig
119
-
type t =
120
-
[ `Parse_error (** -32700: Invalid JSON received *)
121
-
| `Invalid_request (** -32600: The request object is invalid *)
122
-
| `Method_not_found (** -32601: The requested method does not exist *)
123
-
| `Invalid_params (** -32602: Invalid method parameters *)
124
-
| `Internal_error (** -32603: Internal server error *)
125
-
| `Custom of int (** Application-specific error codes *) ]
126
-
127
-
val to_int : [< t ] -> int
128
-
(** [to_int t] converts an error code to its integer representation. *)
129
-
130
-
val of_int : int -> t
131
-
(** [of_int n] converts an integer to an error code. Standard codes are
132
-
mapped to their variants, others become [`Custom n]. *)
133
-
end
134
-
135
-
type error_detail = {
136
-
code : int; (** Error code for programmatic handling *)
137
-
message : string; (** Human-readable error message *)
138
-
data : Jsont.json option; (** Optional additional error data *)
139
-
}
140
-
(** Structured error detail similar to JSON-RPC. *)
141
-
142
-
val error_detail :
143
-
code:[< Error_code.t ] ->
144
-
message:string ->
145
-
?data:Jsont.json ->
146
-
unit ->
147
-
error_detail
148
-
(** [error_detail ~code ~message ?data ()] creates a structured error detail
149
-
using typed error codes.
150
-
151
-
Example:
152
-
{[
153
-
error_detail ~code:`Method_not_found ~message:"Hook callback not found"
154
-
()
155
-
]} *)
156
-
157
-
val error_detail_jsont : error_detail Jsont.t
158
-
(** [error_detail_jsont] is the Jsont codec for error details. *)
159
-
160
-
type success_r = private {
161
-
request_id : string;
162
-
response : Jsont.json option;
163
-
unknown : Unknown.t;
164
-
}
165
-
166
-
type error_r = private {
167
-
request_id : string;
168
-
error : error_detail;
169
-
unknown : Unknown.t;
170
-
}
171
-
172
-
type t =
173
-
| Success of success_r
174
-
| Error of error_r
175
-
(** The type of SDK control responses. Wire format uses "subtype" field:
176
-
"success", "error". *)
177
-
178
-
val jsont : t Jsont.t
179
-
(** [jsont] is the Jsont codec for responses. *)
180
-
181
-
val success : request_id:string -> ?response:Jsont.json -> unit -> t
182
-
(** [success ~request_id ?response ()] creates a success response. *)
183
-
184
-
val error : request_id:string -> error:error_detail -> unit -> t
185
-
(** [error ~request_id ~error ()] creates an error response with structured
186
-
error detail. *)
187
-
end
188
-
189
-
(** {1 Control Envelopes} *)
190
-
191
-
type request_envelope = {
192
-
request_id : string;
193
-
request : Request.t;
194
-
unknown : Unknown.t;
195
-
}
196
-
(** Control request envelope. Wire format has "type": "control_request". *)
197
-
198
-
type response_envelope = { response : Response.t; unknown : Unknown.t }
199
-
(** Control response envelope. Wire format has "type": "control_response". *)
200
-
201
-
val request_envelope_jsont : request_envelope Jsont.t
202
-
(** [request_envelope_jsont] is the Jsont codec for request envelopes. *)
203
-
204
-
val response_envelope_jsont : response_envelope Jsont.t
205
-
(** [response_envelope_jsont] is the Jsont codec for response envelopes. *)
206
-
207
-
val create_request :
208
-
request_id:string -> request:Request.t -> unit -> request_envelope
209
-
(** [create_request ~request_id ~request ()] creates a control request envelope.
210
-
*)
211
-
212
-
val create_response : response:Response.t -> unit -> response_envelope
213
-
(** [create_response ~response ()] creates a control response envelope. *)
214
-
215
-
(** {1 Server Information} *)
216
-
217
-
module Server_info : sig
218
-
(** Server information and capabilities. *)
219
-
220
-
type t
221
-
(** Server metadata and capabilities. *)
222
-
223
-
val jsont : t Jsont.t
224
-
(** [jsont] is the Jsont codec for server info. *)
225
-
226
-
val create :
227
-
version:string ->
228
-
capabilities:string list ->
229
-
commands:string list ->
230
-
output_styles:string list ->
231
-
unit ->
232
-
t
233
-
(** [create ~version ~capabilities ~commands ~output_styles ()] creates server
234
-
info. *)
235
-
236
-
val version : t -> string
237
-
(** [version t] returns the server version. *)
238
-
239
-
val capabilities : t -> string list
240
-
(** [capabilities t] returns the server capabilities. *)
241
-
242
-
val commands : t -> string list
243
-
(** [commands t] returns available commands. *)
244
-
245
-
val output_styles : t -> string list
246
-
(** [output_styles t] returns available output styles. *)
247
-
248
-
val unknown : t -> Unknown.t
249
-
(** [unknown t] returns the unknown fields. *)
250
-
end
-4
proto/dune
-4
proto/dune
-482
proto/hooks.ml
-482
proto/hooks.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Claude Code Hooks System - Wire Format
7
-
8
-
This module defines the wire format for hook configuration. *)
9
-
10
-
(** Hook events that can be intercepted *)
11
-
type event =
12
-
| Pre_tool_use
13
-
| Post_tool_use
14
-
| User_prompt_submit
15
-
| Stop
16
-
| Subagent_stop
17
-
| Pre_compact
18
-
19
-
let event_to_string = function
20
-
| Pre_tool_use -> "PreToolUse"
21
-
| Post_tool_use -> "PostToolUse"
22
-
| User_prompt_submit -> "UserPromptSubmit"
23
-
| Stop -> "Stop"
24
-
| Subagent_stop -> "SubagentStop"
25
-
| Pre_compact -> "PreCompact"
26
-
27
-
let event_of_string = function
28
-
| "PreToolUse" -> Pre_tool_use
29
-
| "PostToolUse" -> Post_tool_use
30
-
| "UserPromptSubmit" -> User_prompt_submit
31
-
| "Stop" -> Stop
32
-
| "SubagentStop" -> Subagent_stop
33
-
| "PreCompact" -> Pre_compact
34
-
| s -> raise (Invalid_argument (Printf.sprintf "Unknown hook event: %s" s))
35
-
36
-
let event_jsont : event Jsont.t =
37
-
Jsont.enum
38
-
[
39
-
("PreToolUse", Pre_tool_use);
40
-
("PostToolUse", Post_tool_use);
41
-
("UserPromptSubmit", User_prompt_submit);
42
-
("Stop", Stop);
43
-
("SubagentStop", Subagent_stop);
44
-
("PreCompact", Pre_compact);
45
-
]
46
-
47
-
(** Context provided to hook callbacks *)
48
-
module Context = struct
49
-
type t = { signal : unit option; unknown : Unknown.t }
50
-
51
-
let create ?signal () =
52
-
let signal = Option.map (fun () -> ()) signal in
53
-
{ signal; unknown = Unknown.empty }
54
-
55
-
let signal t = t.signal
56
-
let unknown t = t.unknown
57
-
58
-
let jsont : t Jsont.t =
59
-
let make unknown = { signal = None; unknown } in
60
-
Jsont.Object.map ~kind:"Context" make
61
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
62
-
|> Jsont.Object.finish
63
-
end
64
-
65
-
(** Hook decision control *)
66
-
type decision = Continue | Block
67
-
68
-
let decision_jsont : decision Jsont.t =
69
-
Jsont.enum [ ("continue", Continue); ("block", Block) ]
70
-
71
-
type result = {
72
-
decision : decision option;
73
-
system_message : string option;
74
-
hook_specific_output : Jsont.json option;
75
-
unknown : Unknown.t;
76
-
}
77
-
(** Generic hook result *)
78
-
79
-
let result_jsont : result Jsont.t =
80
-
let make decision system_message hook_specific_output unknown =
81
-
{ decision; system_message; hook_specific_output; unknown }
82
-
in
83
-
Jsont.Object.map ~kind:"Result" make
84
-
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun r -> r.decision)
85
-
|> Jsont.Object.opt_mem "systemMessage" Jsont.string ~enc:(fun r ->
86
-
r.system_message)
87
-
|> Jsont.Object.opt_mem "hookSpecificOutput" Jsont.json ~enc:(fun r ->
88
-
r.hook_specific_output)
89
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun r -> r.unknown)
90
-
|> Jsont.Object.finish
91
-
92
-
(** {1 PreToolUse Hook} *)
93
-
module PreToolUse = struct
94
-
module Input = struct
95
-
type t = {
96
-
session_id : string;
97
-
transcript_path : string;
98
-
tool_name : string;
99
-
tool_input : Jsont.json;
100
-
unknown : Unknown.t;
101
-
}
102
-
103
-
let session_id t = t.session_id
104
-
let transcript_path t = t.transcript_path
105
-
let tool_name t = t.tool_name
106
-
let tool_input t = t.tool_input
107
-
let unknown t = t.unknown
108
-
109
-
let jsont : t Jsont.t =
110
-
let make session_id transcript_path tool_name tool_input unknown =
111
-
{ session_id; transcript_path; tool_name; tool_input; unknown }
112
-
in
113
-
Jsont.Object.map ~kind:"PreToolUseInput" make
114
-
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
115
-
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
116
-
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:tool_name
117
-
|> Jsont.Object.mem "tool_input" Jsont.json ~enc:tool_input
118
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
119
-
|> Jsont.Object.finish
120
-
end
121
-
122
-
type permission_decision = [ `Allow | `Deny | `Ask ]
123
-
124
-
let permission_decision_jsont : permission_decision Jsont.t =
125
-
Jsont.enum [ ("allow", `Allow); ("deny", `Deny); ("ask", `Ask) ]
126
-
127
-
module Output = struct
128
-
type t = {
129
-
permission_decision : permission_decision option;
130
-
permission_decision_reason : string option;
131
-
updated_input : Jsont.json option;
132
-
unknown : Unknown.t;
133
-
}
134
-
135
-
let jsont : t Jsont.t =
136
-
let make _hook_event_name permission_decision permission_decision_reason
137
-
updated_input unknown =
138
-
{
139
-
permission_decision;
140
-
permission_decision_reason;
141
-
updated_input;
142
-
unknown;
143
-
}
144
-
in
145
-
Jsont.Object.map ~kind:"PreToolUseOutput" make
146
-
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ ->
147
-
"PreToolUse")
148
-
|> Jsont.Object.opt_mem "permissionDecision" permission_decision_jsont
149
-
~enc:(fun o -> o.permission_decision)
150
-
|> Jsont.Object.opt_mem "permissionDecisionReason" Jsont.string
151
-
~enc:(fun o -> o.permission_decision_reason)
152
-
|> Jsont.Object.opt_mem "updatedInput" Jsont.json ~enc:(fun o ->
153
-
o.updated_input)
154
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun o -> o.unknown)
155
-
|> Jsont.Object.finish
156
-
157
-
let allow ?reason ?updated_input () =
158
-
{
159
-
permission_decision = Some `Allow;
160
-
permission_decision_reason = reason;
161
-
updated_input;
162
-
unknown = Unknown.empty;
163
-
}
164
-
165
-
let deny ?reason () =
166
-
{
167
-
permission_decision = Some `Deny;
168
-
permission_decision_reason = reason;
169
-
updated_input = None;
170
-
unknown = Unknown.empty;
171
-
}
172
-
173
-
let ask ?reason () =
174
-
{
175
-
permission_decision = Some `Ask;
176
-
permission_decision_reason = reason;
177
-
updated_input = None;
178
-
unknown = Unknown.empty;
179
-
}
180
-
181
-
let continue () =
182
-
{
183
-
permission_decision = None;
184
-
permission_decision_reason = None;
185
-
updated_input = None;
186
-
unknown = Unknown.empty;
187
-
}
188
-
end
189
-
end
190
-
191
-
(** {1 PostToolUse Hook} *)
192
-
module PostToolUse = struct
193
-
module Input = struct
194
-
type t = {
195
-
session_id : string;
196
-
transcript_path : string;
197
-
tool_name : string;
198
-
tool_input : Jsont.json;
199
-
tool_response : Jsont.json;
200
-
unknown : Unknown.t;
201
-
}
202
-
203
-
let session_id t = t.session_id
204
-
let transcript_path t = t.transcript_path
205
-
let tool_name t = t.tool_name
206
-
let tool_input t = t.tool_input
207
-
let tool_response t = t.tool_response
208
-
let unknown t = t.unknown
209
-
210
-
let jsont : t Jsont.t =
211
-
let make session_id transcript_path tool_name tool_input tool_response
212
-
unknown =
213
-
{
214
-
session_id;
215
-
transcript_path;
216
-
tool_name;
217
-
tool_input;
218
-
tool_response;
219
-
unknown;
220
-
}
221
-
in
222
-
Jsont.Object.map ~kind:"PostToolUseInput" make
223
-
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
224
-
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
225
-
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:tool_name
226
-
|> Jsont.Object.mem "tool_input" Jsont.json ~enc:tool_input
227
-
|> Jsont.Object.mem "tool_response" Jsont.json ~enc:tool_response
228
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
229
-
|> Jsont.Object.finish
230
-
end
231
-
232
-
module Output = struct
233
-
type t = {
234
-
decision : decision option;
235
-
reason : string option;
236
-
additional_context : string option;
237
-
unknown : Unknown.t;
238
-
}
239
-
240
-
let jsont : t Jsont.t =
241
-
let make _hook_event_name decision reason additional_context unknown =
242
-
{ decision; reason; additional_context; unknown }
243
-
in
244
-
Jsont.Object.map ~kind:"PostToolUseOutput" make
245
-
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ ->
246
-
"PostToolUse")
247
-
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o ->
248
-
o.decision)
249
-
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
250
-
|> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o ->
251
-
o.additional_context)
252
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun o -> o.unknown)
253
-
|> Jsont.Object.finish
254
-
255
-
let continue ?additional_context () =
256
-
{
257
-
decision = None;
258
-
reason = None;
259
-
additional_context;
260
-
unknown = Unknown.empty;
261
-
}
262
-
263
-
let block ?reason ?additional_context () =
264
-
{
265
-
decision = Some Block;
266
-
reason;
267
-
additional_context;
268
-
unknown = Unknown.empty;
269
-
}
270
-
end
271
-
end
272
-
273
-
(** {1 UserPromptSubmit Hook} *)
274
-
module UserPromptSubmit = struct
275
-
module Input = struct
276
-
type t = {
277
-
session_id : string;
278
-
transcript_path : string;
279
-
prompt : string;
280
-
unknown : Unknown.t;
281
-
}
282
-
283
-
let session_id t = t.session_id
284
-
let transcript_path t = t.transcript_path
285
-
let prompt t = t.prompt
286
-
let unknown t = t.unknown
287
-
288
-
let jsont : t Jsont.t =
289
-
let make session_id transcript_path prompt unknown =
290
-
{ session_id; transcript_path; prompt; unknown }
291
-
in
292
-
Jsont.Object.map ~kind:"UserPromptSubmitInput" make
293
-
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
294
-
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
295
-
|> Jsont.Object.mem "prompt" Jsont.string ~enc:prompt
296
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
297
-
|> Jsont.Object.finish
298
-
end
299
-
300
-
module Output = struct
301
-
type t = {
302
-
decision : decision option;
303
-
reason : string option;
304
-
additional_context : string option;
305
-
unknown : Unknown.t;
306
-
}
307
-
308
-
let jsont : t Jsont.t =
309
-
let make _hook_event_name decision reason additional_context unknown =
310
-
{ decision; reason; additional_context; unknown }
311
-
in
312
-
Jsont.Object.map ~kind:"UserPromptSubmitOutput" make
313
-
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ ->
314
-
"UserPromptSubmit")
315
-
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o ->
316
-
o.decision)
317
-
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
318
-
|> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o ->
319
-
o.additional_context)
320
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun o -> o.unknown)
321
-
|> Jsont.Object.finish
322
-
323
-
let continue ?additional_context () =
324
-
{
325
-
decision = None;
326
-
reason = None;
327
-
additional_context;
328
-
unknown = Unknown.empty;
329
-
}
330
-
331
-
let block ?reason () =
332
-
{
333
-
decision = Some Block;
334
-
reason;
335
-
additional_context = None;
336
-
unknown = Unknown.empty;
337
-
}
338
-
end
339
-
end
340
-
341
-
(** {1 Stop Hook} *)
342
-
module Stop = struct
343
-
module Input = struct
344
-
type t = {
345
-
session_id : string;
346
-
transcript_path : string;
347
-
stop_hook_active : bool;
348
-
unknown : Unknown.t;
349
-
}
350
-
351
-
let session_id t = t.session_id
352
-
let transcript_path t = t.transcript_path
353
-
let stop_hook_active t = t.stop_hook_active
354
-
let unknown t = t.unknown
355
-
356
-
let jsont : t Jsont.t =
357
-
let make session_id transcript_path stop_hook_active unknown =
358
-
{ session_id; transcript_path; stop_hook_active; unknown }
359
-
in
360
-
Jsont.Object.map ~kind:"StopInput" make
361
-
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
362
-
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
363
-
|> Jsont.Object.mem "stop_hook_active" Jsont.bool ~enc:stop_hook_active
364
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
365
-
|> Jsont.Object.finish
366
-
end
367
-
368
-
module Output = struct
369
-
type t = {
370
-
decision : decision option;
371
-
reason : string option;
372
-
unknown : Unknown.t;
373
-
}
374
-
375
-
let jsont : t Jsont.t =
376
-
let make _hook_event_name decision reason unknown =
377
-
{ decision; reason; unknown }
378
-
in
379
-
Jsont.Object.map ~kind:"StopOutput" make
380
-
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ -> "Stop")
381
-
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o ->
382
-
o.decision)
383
-
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
384
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun o -> o.unknown)
385
-
|> Jsont.Object.finish
386
-
387
-
let continue () =
388
-
{ decision = None; reason = None; unknown = Unknown.empty }
389
-
390
-
let block ?reason () =
391
-
{ decision = Some Block; reason; unknown = Unknown.empty }
392
-
end
393
-
end
394
-
395
-
(** {1 SubagentStop Hook} - Same structure as Stop *)
396
-
module SubagentStop = struct
397
-
module Input = struct
398
-
type t = Stop.Input.t
399
-
400
-
let jsont = Stop.Input.jsont
401
-
let session_id = Stop.Input.session_id
402
-
let transcript_path = Stop.Input.transcript_path
403
-
let stop_hook_active = Stop.Input.stop_hook_active
404
-
let unknown = Stop.Input.unknown
405
-
end
406
-
407
-
module Output = struct
408
-
type t = Stop.Output.t
409
-
410
-
let jsont : t Jsont.t =
411
-
let make _hook_event_name decision reason unknown : t =
412
-
{ Stop.Output.decision; reason; unknown }
413
-
in
414
-
Jsont.Object.map ~kind:"SubagentStopOutput" make
415
-
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ ->
416
-
"SubagentStop")
417
-
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun (o : t) ->
418
-
o.Stop.Output.decision)
419
-
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun (o : t) ->
420
-
o.Stop.Output.reason)
421
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (o : t) ->
422
-
o.Stop.Output.unknown)
423
-
|> Jsont.Object.finish
424
-
425
-
let continue = Stop.Output.continue
426
-
let block = Stop.Output.block
427
-
end
428
-
end
429
-
430
-
(** {1 PreCompact Hook} *)
431
-
module PreCompact = struct
432
-
module Input = struct
433
-
type t = {
434
-
session_id : string;
435
-
transcript_path : string;
436
-
unknown : Unknown.t;
437
-
}
438
-
439
-
let session_id t = t.session_id
440
-
let transcript_path t = t.transcript_path
441
-
let unknown t = t.unknown
442
-
443
-
let jsont : t Jsont.t =
444
-
let make session_id transcript_path unknown =
445
-
{ session_id; transcript_path; unknown }
446
-
in
447
-
Jsont.Object.map ~kind:"PreCompactInput" make
448
-
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
449
-
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
450
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
451
-
|> Jsont.Object.finish
452
-
end
453
-
454
-
module Output = struct
455
-
type t = unit
456
-
457
-
let jsont : t Jsont.t =
458
-
Jsont.Object.map ~kind:"PreCompactOutput" (fun _hook_event_name -> ())
459
-
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun () ->
460
-
"PreCompact")
461
-
|> Jsont.Object.finish
462
-
463
-
let continue () = ()
464
-
end
465
-
end
466
-
467
-
(** {1 Result Builders} *)
468
-
let continue ?system_message ?hook_specific_output () =
469
-
{
470
-
decision = None;
471
-
system_message;
472
-
hook_specific_output;
473
-
unknown = Unknown.empty;
474
-
}
475
-
476
-
let block ?system_message ?hook_specific_output () =
477
-
{
478
-
decision = Some Block;
479
-
system_message;
480
-
hook_specific_output;
481
-
unknown = Unknown.empty;
482
-
}
-363
proto/hooks.mli
-363
proto/hooks.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Claude Code Hooks System - Wire Format
7
-
8
-
This module defines the wire format for hook configuration. Hooks allow you
9
-
to intercept and control events in Claude Code sessions, such as tool usage,
10
-
prompt submission, and session stops.
11
-
12
-
{1 Overview}
13
-
14
-
Hooks are organized by event type, with each event having:
15
-
- A typed input structure (accessible via submodules)
16
-
- A typed output structure for responses
17
-
- Helper functions for common responses
18
-
19
-
This is the wire format module - it does not include the callback system or
20
-
Eio dependencies. For the full hooks system with callbacks, see the [Hooks]
21
-
module in the [lib] directory. *)
22
-
23
-
(** {1 Hook Events} *)
24
-
25
-
(** Hook event types *)
26
-
type event =
27
-
| Pre_tool_use (** Fires before a tool is executed *)
28
-
| Post_tool_use (** Fires after a tool completes *)
29
-
| User_prompt_submit (** Fires when user submits a prompt *)
30
-
| Stop (** Fires when conversation stops *)
31
-
| Subagent_stop (** Fires when a subagent stops *)
32
-
| Pre_compact (** Fires before message compaction *)
33
-
34
-
val event_to_string : event -> string
35
-
(** [event_to_string event] converts an event to its wire format string. Wire
36
-
format: "PreToolUse", "PostToolUse", "UserPromptSubmit", "Stop",
37
-
"SubagentStop", "PreCompact" *)
38
-
39
-
val event_of_string : string -> event
40
-
(** [event_of_string s] parses an event from its wire format string.
41
-
@raise Invalid_argument if the string is not a valid event. *)
42
-
43
-
val event_jsont : event Jsont.t
44
-
(** [event_jsont] is the Jsont codec for hook events. *)
45
-
46
-
(** {1 Context} *)
47
-
48
-
module Context : sig
49
-
(** Context provided to hook callbacks. *)
50
-
51
-
type t
52
-
(** The type of hook context. *)
53
-
54
-
val jsont : t Jsont.t
55
-
(** [jsont] is the Jsont codec for hook context. Preserves unknown fields. *)
56
-
57
-
val create : ?signal:unit -> unit -> t
58
-
(** [create ?signal ()] creates a new context.
59
-
@param signal Optional abort signal support (future use) *)
60
-
61
-
val signal : t -> unit option
62
-
(** [signal t] returns the optional abort signal. *)
63
-
64
-
val unknown : t -> Unknown.t
65
-
(** [unknown t] returns the unknown fields. *)
66
-
end
67
-
68
-
(** {1 Decisions} *)
69
-
70
-
(** Hook decision control *)
71
-
type decision =
72
-
| Continue (** Allow the action to proceed *)
73
-
| Block (** Block the action *)
74
-
75
-
val decision_jsont : decision Jsont.t
76
-
(** [decision_jsont] is the Jsont codec for hook decisions. Wire format:
77
-
"continue", "block" *)
78
-
79
-
(** {1 Typed Hook Modules} *)
80
-
81
-
(** PreToolUse hook - fires before tool execution *)
82
-
module PreToolUse : sig
83
-
(** {2 Input} *)
84
-
85
-
module Input : sig
86
-
type t
87
-
(** Typed input for PreToolUse hooks *)
88
-
89
-
val jsont : t Jsont.t
90
-
(** [jsont] is the Jsont codec for PreToolUse input. *)
91
-
92
-
val session_id : t -> string
93
-
(** [session_id t] returns the session ID. *)
94
-
95
-
val transcript_path : t -> string
96
-
(** [transcript_path t] returns the transcript file path. *)
97
-
98
-
val tool_name : t -> string
99
-
(** [tool_name t] returns the tool name being invoked. *)
100
-
101
-
val tool_input : t -> Jsont.json
102
-
(** [tool_input t] returns the tool's input as raw JSON. *)
103
-
104
-
val unknown : t -> Unknown.t
105
-
(** [unknown t] returns the unknown fields. *)
106
-
end
107
-
108
-
(** {2 Output} *)
109
-
110
-
type permission_decision = [ `Allow | `Deny | `Ask ]
111
-
(** Permission decision for tool usage. Wire format: "allow", "deny", "ask" *)
112
-
113
-
val permission_decision_jsont : permission_decision Jsont.t
114
-
(** [permission_decision_jsont] is the Jsont codec for permission decisions.
115
-
*)
116
-
117
-
module Output : sig
118
-
type t
119
-
(** Typed output for PreToolUse hooks *)
120
-
121
-
val jsont : t Jsont.t
122
-
(** [jsont] is the Jsont codec for PreToolUse output. *)
123
-
124
-
val allow : ?reason:string -> ?updated_input:Jsont.json -> unit -> t
125
-
(** [allow ?reason ?updated_input ()] creates an allow response.
126
-
@param reason Optional explanation for allowing
127
-
@param updated_input Optional modified tool input *)
128
-
129
-
val deny : ?reason:string -> unit -> t
130
-
(** [deny ?reason ()] creates a deny response.
131
-
@param reason Optional explanation for denying *)
132
-
133
-
val ask : ?reason:string -> unit -> t
134
-
(** [ask ?reason ()] creates an ask response to prompt the user.
135
-
@param reason Optional explanation for asking *)
136
-
137
-
val continue : unit -> t
138
-
(** [continue ()] creates a continue response with no decision. *)
139
-
end
140
-
end
141
-
142
-
(** PostToolUse hook - fires after tool execution *)
143
-
module PostToolUse : sig
144
-
(** {2 Input} *)
145
-
146
-
module Input : sig
147
-
type t
148
-
(** Typed input for PostToolUse hooks *)
149
-
150
-
val jsont : t Jsont.t
151
-
(** [jsont] is the Jsont codec for PostToolUse input. *)
152
-
153
-
val session_id : t -> string
154
-
(** [session_id t] returns the session ID. *)
155
-
156
-
val transcript_path : t -> string
157
-
(** [transcript_path t] returns the transcript file path. *)
158
-
159
-
val tool_name : t -> string
160
-
(** [tool_name t] returns the tool name that was invoked. *)
161
-
162
-
val tool_input : t -> Jsont.json
163
-
(** [tool_input t] returns the tool's input as raw JSON. *)
164
-
165
-
val tool_response : t -> Jsont.json
166
-
(** [tool_response t] returns the tool's response as raw JSON. *)
167
-
168
-
val unknown : t -> Unknown.t
169
-
(** [unknown t] returns the unknown fields. *)
170
-
end
171
-
172
-
(** {2 Output} *)
173
-
174
-
module Output : sig
175
-
type t
176
-
(** Typed output for PostToolUse hooks *)
177
-
178
-
val jsont : t Jsont.t
179
-
(** [jsont] is the Jsont codec for PostToolUse output. *)
180
-
181
-
val continue : ?additional_context:string -> unit -> t
182
-
(** [continue ?additional_context ()] creates a continue response.
183
-
@param additional_context Optional context to add to the transcript *)
184
-
185
-
val block : ?reason:string -> ?additional_context:string -> unit -> t
186
-
(** [block ?reason ?additional_context ()] creates a block response.
187
-
@param reason Optional explanation for blocking
188
-
@param additional_context Optional context to add to the transcript *)
189
-
end
190
-
end
191
-
192
-
(** UserPromptSubmit hook - fires when user submits a prompt *)
193
-
module UserPromptSubmit : sig
194
-
(** {2 Input} *)
195
-
196
-
module Input : sig
197
-
type t
198
-
(** Typed input for UserPromptSubmit hooks *)
199
-
200
-
val jsont : t Jsont.t
201
-
(** [jsont] is the Jsont codec for UserPromptSubmit input. *)
202
-
203
-
val session_id : t -> string
204
-
(** [session_id t] returns the session ID. *)
205
-
206
-
val transcript_path : t -> string
207
-
(** [transcript_path t] returns the transcript file path. *)
208
-
209
-
val prompt : t -> string
210
-
(** [prompt t] returns the user's prompt text. *)
211
-
212
-
val unknown : t -> Unknown.t
213
-
(** [unknown t] returns the unknown fields. *)
214
-
end
215
-
216
-
(** {2 Output} *)
217
-
218
-
module Output : sig
219
-
type t
220
-
(** Typed output for UserPromptSubmit hooks *)
221
-
222
-
val jsont : t Jsont.t
223
-
(** [jsont] is the Jsont codec for UserPromptSubmit output. *)
224
-
225
-
val continue : ?additional_context:string -> unit -> t
226
-
(** [continue ?additional_context ()] creates a continue response.
227
-
@param additional_context Optional context to add to the transcript *)
228
-
229
-
val block : ?reason:string -> unit -> t
230
-
(** [block ?reason ()] creates a block response.
231
-
@param reason Optional explanation for blocking *)
232
-
end
233
-
end
234
-
235
-
(** Stop hook - fires when conversation stops *)
236
-
module Stop : sig
237
-
(** {2 Input} *)
238
-
239
-
module Input : sig
240
-
type t
241
-
(** Typed input for Stop hooks *)
242
-
243
-
val jsont : t Jsont.t
244
-
(** [jsont] is the Jsont codec for Stop input. *)
245
-
246
-
val session_id : t -> string
247
-
(** [session_id t] returns the session ID. *)
248
-
249
-
val transcript_path : t -> string
250
-
(** [transcript_path t] returns the transcript file path. *)
251
-
252
-
val stop_hook_active : t -> bool
253
-
(** [stop_hook_active t] returns whether stop hooks are active. *)
254
-
255
-
val unknown : t -> Unknown.t
256
-
(** [unknown t] returns the unknown fields. *)
257
-
end
258
-
259
-
(** {2 Output} *)
260
-
261
-
module Output : sig
262
-
type t
263
-
(** Typed output for Stop hooks *)
264
-
265
-
val jsont : t Jsont.t
266
-
(** [jsont] is the Jsont codec for Stop output. *)
267
-
268
-
val continue : unit -> t
269
-
(** [continue ()] creates a continue response. *)
270
-
271
-
val block : ?reason:string -> unit -> t
272
-
(** [block ?reason ()] creates a block response.
273
-
@param reason Optional explanation for blocking *)
274
-
end
275
-
end
276
-
277
-
(** SubagentStop hook - fires when a subagent stops *)
278
-
module SubagentStop : sig
279
-
(** {2 Input} *)
280
-
281
-
module Input : sig
282
-
type t = Stop.Input.t
283
-
(** Same structure as Stop.Input *)
284
-
285
-
val jsont : t Jsont.t
286
-
val session_id : t -> string
287
-
val transcript_path : t -> string
288
-
val stop_hook_active : t -> bool
289
-
val unknown : t -> Unknown.t
290
-
end
291
-
292
-
(** {2 Output} *)
293
-
294
-
module Output : sig
295
-
type t = Stop.Output.t
296
-
(** Same structure as Stop.Output *)
297
-
298
-
val jsont : t Jsont.t
299
-
val continue : unit -> t
300
-
val block : ?reason:string -> unit -> t
301
-
end
302
-
end
303
-
304
-
(** PreCompact hook - fires before message compaction *)
305
-
module PreCompact : sig
306
-
(** {2 Input} *)
307
-
308
-
module Input : sig
309
-
type t
310
-
(** Typed input for PreCompact hooks *)
311
-
312
-
val jsont : t Jsont.t
313
-
(** [jsont] is the Jsont codec for PreCompact input. *)
314
-
315
-
val session_id : t -> string
316
-
(** [session_id t] returns the session ID. *)
317
-
318
-
val transcript_path : t -> string
319
-
(** [transcript_path t] returns the transcript file path. *)
320
-
321
-
val unknown : t -> Unknown.t
322
-
(** [unknown t] returns the unknown fields. *)
323
-
end
324
-
325
-
(** {2 Output} *)
326
-
327
-
module Output : sig
328
-
type t = unit
329
-
(** PreCompact has no specific output *)
330
-
331
-
val jsont : t Jsont.t
332
-
(** [jsont] is the Jsont codec for PreCompact output (unit codec). *)
333
-
334
-
val continue : unit -> t
335
-
(** [continue ()] returns unit. *)
336
-
end
337
-
end
338
-
339
-
(** {1 Generic Hook Result} *)
340
-
341
-
type result = {
342
-
decision : decision option;
343
-
system_message : string option;
344
-
hook_specific_output : Jsont.json option;
345
-
unknown : Unknown.t;
346
-
}
347
-
(** Generic result structure for hooks *)
348
-
349
-
val result_jsont : result Jsont.t
350
-
(** [result_jsont] is the Jsont codec for hook results. *)
351
-
352
-
val continue :
353
-
?system_message:string -> ?hook_specific_output:Jsont.json -> unit -> result
354
-
(** [continue ?system_message ?hook_specific_output ()] creates a continue
355
-
result.
356
-
@param system_message Optional message to add to system context
357
-
@param hook_specific_output Optional hook-specific output data *)
358
-
359
-
val block :
360
-
?system_message:string -> ?hook_specific_output:Jsont.json -> unit -> result
361
-
(** [block ?system_message ?hook_specific_output ()] creates a block result.
362
-
@param system_message Optional message to add to system context
363
-
@param hook_specific_output Optional hook-specific output data *)
-72
proto/incoming.ml
-72
proto/incoming.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Incoming messages from Claude CLI.
7
-
8
-
This uses the Control module's request_envelope_jsont and
9
-
response_envelope_jsont for control messages, and Message.jsont for
10
-
conversation messages. The top-level discriminator is the "type" field. *)
11
-
12
-
type t =
13
-
| Message of Message.t
14
-
| Control_response of Control.response_envelope
15
-
| Control_request of Control.request_envelope
16
-
17
-
let jsont : t Jsont.t =
18
-
(* Message types use "user", "assistant", "system", "result" as type values.
19
-
Control uses "control_request" and "control_response".
20
-
21
-
We use case_mem for all types. Note: we use the inner message codecs
22
-
(User.incoming_jsont, etc.) rather than Message.jsont to avoid nesting
23
-
case_mem on the same "type" field. *)
24
-
let case_control_request =
25
-
Jsont.Object.Case.map "control_request" Control.request_envelope_jsont
26
-
~dec:(fun v -> Control_request v)
27
-
in
28
-
let case_control_response =
29
-
Jsont.Object.Case.map "control_response" Control.response_envelope_jsont
30
-
~dec:(fun v -> Control_response v)
31
-
in
32
-
let case_user =
33
-
Jsont.Object.Case.map "user" Message.User.incoming_jsont ~dec:(fun v ->
34
-
Message (Message.User v))
35
-
in
36
-
let case_assistant =
37
-
Jsont.Object.Case.map "assistant" Message.Assistant.incoming_jsont
38
-
~dec:(fun v -> Message (Message.Assistant v))
39
-
in
40
-
let case_system =
41
-
Jsont.Object.Case.map "system" Message.System.jsont ~dec:(fun v ->
42
-
Message (Message.System v))
43
-
in
44
-
let case_result =
45
-
Jsont.Object.Case.map "result" Message.Result.jsont ~dec:(fun v ->
46
-
Message (Message.Result v))
47
-
in
48
-
let enc_case = function
49
-
| Control_request v -> Jsont.Object.Case.value case_control_request v
50
-
| Control_response v -> Jsont.Object.Case.value case_control_response v
51
-
| Message msg -> (
52
-
match msg with
53
-
| Message.User u -> Jsont.Object.Case.value case_user u
54
-
| Message.Assistant a -> Jsont.Object.Case.value case_assistant a
55
-
| Message.System s -> Jsont.Object.Case.value case_system s
56
-
| Message.Result r -> Jsont.Object.Case.value case_result r)
57
-
in
58
-
let cases =
59
-
Jsont.Object.Case.
60
-
[
61
-
make case_control_request;
62
-
make case_control_response;
63
-
make case_user;
64
-
make case_assistant;
65
-
make case_system;
66
-
make case_result;
67
-
]
68
-
in
69
-
Jsont.Object.map ~kind:"Incoming" Fun.id
70
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
71
-
~tag_to_string:Fun.id ~tag_compare:String.compare
72
-
|> Jsont.Object.finish
-26
proto/incoming.mli
-26
proto/incoming.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Incoming messages from the Claude CLI.
7
-
8
-
This module defines a discriminated union of all possible message types that
9
-
can be received from the Claude CLI, with a single jsont codec.
10
-
11
-
The codec uses the "type" field to discriminate between message types:
12
-
- "user", "assistant", "system", "result" -> Message variant
13
-
- "control_response" -> Control_response variant
14
-
- "control_request" -> Control_request variant
15
-
16
-
This provides a clean, type-safe way to decode incoming messages in a single
17
-
operation. *)
18
-
19
-
type t =
20
-
| Message of Message.t
21
-
| Control_response of Control.response_envelope
22
-
| Control_request of Control.request_envelope
23
-
24
-
val jsont : t Jsont.t
25
-
(** Codec for incoming messages. Uses the "type" field to discriminate. Use
26
-
[Jsont.pp_value jsont ()] for pretty-printing. *)
-372
proto/message.ml
-372
proto/message.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
module User = struct
7
-
type content = String of string | Blocks of Content_block.t list
8
-
type t = { content : content; unknown : Unknown.t }
9
-
10
-
let create_string s = { content = String s; unknown = Unknown.empty }
11
-
12
-
let create_blocks blocks =
13
-
{ content = Blocks blocks; unknown = Unknown.empty }
14
-
15
-
let create_with_tool_result ~tool_use_id ~content ?is_error () =
16
-
let tool_result =
17
-
Content_block.tool_result ~tool_use_id ~content ?is_error ()
18
-
in
19
-
{ content = Blocks [ tool_result ]; unknown = Unknown.empty }
20
-
21
-
let make content unknown = { content; unknown }
22
-
let content t = t.content
23
-
let unknown t = t.unknown
24
-
25
-
(* Decode content from json value *)
26
-
let decode_content json =
27
-
match json with
28
-
| Jsont.String (s, _) -> String s
29
-
| Jsont.Array (items, _) ->
30
-
let blocks =
31
-
List.map
32
-
(fun j ->
33
-
match Jsont.Json.decode Content_block.jsont j with
34
-
| Ok v -> v
35
-
| Error e -> invalid_arg ("Invalid content block: " ^ e))
36
-
items
37
-
in
38
-
Blocks blocks
39
-
| _ -> failwith "Content must be string or array"
40
-
41
-
(* Encode content to json value *)
42
-
let encode_content = function
43
-
| String s -> Jsont.String (s, Jsont.Meta.none)
44
-
| Blocks blocks ->
45
-
let jsons =
46
-
List.map
47
-
(fun b ->
48
-
match Jsont.Json.encode Content_block.jsont b with
49
-
| Ok json -> json
50
-
| Error e -> invalid_arg ("encode_content: " ^ e))
51
-
blocks
52
-
in
53
-
Jsont.Array (jsons, Jsont.Meta.none)
54
-
55
-
let jsont : t Jsont.t =
56
-
Jsont.Object.map ~kind:"User" (fun json_content unknown ->
57
-
let content = decode_content json_content in
58
-
make content unknown)
59
-
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t ->
60
-
encode_content (content t))
61
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
62
-
|> Jsont.Object.finish
63
-
64
-
(* Jsont codec for parsing incoming user messages from CLI *)
65
-
let incoming_jsont : t Jsont.t =
66
-
let message_jsont =
67
-
Jsont.Object.map ~kind:"UserMessage" (fun json_content ->
68
-
let content = decode_content json_content in
69
-
{ content; unknown = Unknown.empty })
70
-
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t ->
71
-
encode_content (content t))
72
-
|> Jsont.Object.finish
73
-
in
74
-
Jsont.Object.map ~kind:"UserEnvelope" Fun.id
75
-
|> Jsont.Object.mem "message" message_jsont ~enc:Fun.id
76
-
|> Jsont.Object.finish
77
-
78
-
(* Jsont codec for outgoing user messages - wraps in message envelope *)
79
-
let outgoing_jsont : t Jsont.t =
80
-
(* The inner message object with role and content *)
81
-
let message_jsont =
82
-
Jsont.Object.map ~kind:"UserOutgoingMessage" (fun _role json_content ->
83
-
let content = decode_content json_content in
84
-
{ content; unknown = Unknown.empty })
85
-
|> Jsont.Object.mem "role" Jsont.string ~enc:(fun _ -> "user")
86
-
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t ->
87
-
encode_content (content t))
88
-
|> Jsont.Object.finish
89
-
in
90
-
Jsont.Object.map ~kind:"UserOutgoingEnvelope" Fun.id
91
-
|> Jsont.Object.mem "message" message_jsont ~enc:Fun.id
92
-
|> Jsont.Object.finish
93
-
end
94
-
95
-
module Assistant = struct
96
-
type error =
97
-
[ `Authentication_failed
98
-
| `Billing_error
99
-
| `Rate_limit
100
-
| `Invalid_request
101
-
| `Server_error
102
-
| `Unknown ]
103
-
104
-
let error_jsont : error Jsont.t =
105
-
Jsont.enum
106
-
[
107
-
("authentication_failed", `Authentication_failed);
108
-
("billing_error", `Billing_error);
109
-
("rate_limit", `Rate_limit);
110
-
("invalid_request", `Invalid_request);
111
-
("server_error", `Server_error);
112
-
("unknown", `Unknown);
113
-
]
114
-
115
-
type t = {
116
-
content : Content_block.t list;
117
-
model : string;
118
-
error : error option;
119
-
unknown : Unknown.t;
120
-
}
121
-
122
-
let create ~content ~model ?error () =
123
-
{ content; model; error; unknown = Unknown.empty }
124
-
125
-
let make content model error unknown = { content; model; error; unknown }
126
-
let content t = t.content
127
-
let model t = t.model
128
-
let error t = t.error
129
-
let unknown t = t.unknown
130
-
131
-
let jsont : t Jsont.t =
132
-
Jsont.Object.map ~kind:"Assistant" make
133
-
|> Jsont.Object.mem "content" (Jsont.list Content_block.jsont) ~enc:content
134
-
|> Jsont.Object.mem "model" Jsont.string ~enc:model
135
-
|> Jsont.Object.opt_mem "error" error_jsont ~enc:error
136
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
137
-
|> Jsont.Object.finish
138
-
139
-
(* Jsont codec for parsing incoming assistant messages from CLI *)
140
-
let incoming_jsont : t Jsont.t =
141
-
Jsont.Object.map ~kind:"AssistantEnvelope" Fun.id
142
-
|> Jsont.Object.mem "message" jsont ~enc:Fun.id
143
-
|> Jsont.Object.finish
144
-
end
145
-
146
-
module System = struct
147
-
(** System messages as a discriminated union on "subtype" field *)
148
-
149
-
type init = {
150
-
session_id : string option;
151
-
model : string option;
152
-
cwd : string option;
153
-
unknown : Unknown.t;
154
-
}
155
-
156
-
type error = { error : string; unknown : Unknown.t }
157
-
type t = Init of init | Error of error
158
-
159
-
(* Accessors *)
160
-
let session_id = function Init i -> i.session_id | _ -> None
161
-
let model = function Init i -> i.model | _ -> None
162
-
let cwd = function Init i -> i.cwd | _ -> None
163
-
let error_msg = function Error e -> Some e.error | _ -> None
164
-
let unknown = function Init i -> i.unknown | Error e -> e.unknown
165
-
166
-
(* Constructors *)
167
-
let init ?session_id ?model ?cwd () =
168
-
Init { session_id; model; cwd; unknown = Unknown.empty }
169
-
170
-
let error ~error = Error { error; unknown = Unknown.empty }
171
-
172
-
(* Individual record codecs *)
173
-
let init_jsont : init Jsont.t =
174
-
let make session_id model cwd unknown : init =
175
-
{ session_id; model; cwd; unknown }
176
-
in
177
-
Jsont.Object.map ~kind:"SystemInit" make
178
-
|> Jsont.Object.opt_mem "session_id" Jsont.string ~enc:(fun (r : init) ->
179
-
r.session_id)
180
-
|> Jsont.Object.opt_mem "model" Jsont.string ~enc:(fun (r : init) ->
181
-
r.model)
182
-
|> Jsont.Object.opt_mem "cwd" Jsont.string ~enc:(fun (r : init) -> r.cwd)
183
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : init) -> r.unknown)
184
-
|> Jsont.Object.finish
185
-
186
-
let error_jsont : error Jsont.t =
187
-
let make err unknown : error = { error = err; unknown } in
188
-
Jsont.Object.map ~kind:"SystemError" make
189
-
|> Jsont.Object.mem "error" Jsont.string ~enc:(fun (r : error) -> r.error)
190
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : error) ->
191
-
r.unknown)
192
-
|> Jsont.Object.finish
193
-
194
-
(* Main codec using case_mem for "subtype" discriminator *)
195
-
let jsont : t Jsont.t =
196
-
let case_init =
197
-
Jsont.Object.Case.map "init" init_jsont ~dec:(fun v -> Init v)
198
-
in
199
-
let case_error =
200
-
Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
201
-
in
202
-
let enc_case = function
203
-
| Init v -> Jsont.Object.Case.value case_init v
204
-
| Error v -> Jsont.Object.Case.value case_error v
205
-
in
206
-
let cases = Jsont.Object.Case.[ make case_init; make case_error ] in
207
-
Jsont.Object.map ~kind:"System" Fun.id
208
-
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
209
-
~tag_to_string:Fun.id ~tag_compare:String.compare
210
-
|> Jsont.Object.finish
211
-
end
212
-
213
-
module Result = struct
214
-
module Usage = struct
215
-
type t = {
216
-
input_tokens : int option;
217
-
output_tokens : int option;
218
-
total_tokens : int option;
219
-
cache_creation_input_tokens : int option;
220
-
cache_read_input_tokens : int option;
221
-
unknown : Unknown.t;
222
-
}
223
-
224
-
let make input_tokens output_tokens total_tokens cache_creation_input_tokens
225
-
cache_read_input_tokens unknown =
226
-
{
227
-
input_tokens;
228
-
output_tokens;
229
-
total_tokens;
230
-
cache_creation_input_tokens;
231
-
cache_read_input_tokens;
232
-
unknown;
233
-
}
234
-
235
-
let create ?input_tokens ?output_tokens ?total_tokens
236
-
?cache_creation_input_tokens ?cache_read_input_tokens () =
237
-
{
238
-
input_tokens;
239
-
output_tokens;
240
-
total_tokens;
241
-
cache_creation_input_tokens;
242
-
cache_read_input_tokens;
243
-
unknown = Unknown.empty;
244
-
}
245
-
246
-
let input_tokens t = t.input_tokens
247
-
let output_tokens t = t.output_tokens
248
-
let total_tokens t = t.total_tokens
249
-
let cache_creation_input_tokens t = t.cache_creation_input_tokens
250
-
let cache_read_input_tokens t = t.cache_read_input_tokens
251
-
let unknown t = t.unknown
252
-
253
-
let jsont : t Jsont.t =
254
-
Jsont.Object.map ~kind:"Usage" make
255
-
|> Jsont.Object.opt_mem "input_tokens" Jsont.int ~enc:input_tokens
256
-
|> Jsont.Object.opt_mem "output_tokens" Jsont.int ~enc:output_tokens
257
-
|> Jsont.Object.opt_mem "total_tokens" Jsont.int ~enc:total_tokens
258
-
|> Jsont.Object.opt_mem "cache_creation_input_tokens" Jsont.int
259
-
~enc:cache_creation_input_tokens
260
-
|> Jsont.Object.opt_mem "cache_read_input_tokens" Jsont.int
261
-
~enc:cache_read_input_tokens
262
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
263
-
|> Jsont.Object.finish
264
-
end
265
-
266
-
type t = {
267
-
subtype : string;
268
-
duration_ms : int;
269
-
duration_api_ms : int;
270
-
is_error : bool;
271
-
num_turns : int;
272
-
session_id : string;
273
-
total_cost_usd : float option;
274
-
usage : Usage.t option;
275
-
result : string option;
276
-
structured_output : Jsont.json option;
277
-
unknown : Unknown.t;
278
-
}
279
-
280
-
let create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
281
-
~session_id ?total_cost_usd ?usage ?result ?structured_output () =
282
-
{
283
-
subtype;
284
-
duration_ms;
285
-
duration_api_ms;
286
-
is_error;
287
-
num_turns;
288
-
session_id;
289
-
total_cost_usd;
290
-
usage;
291
-
result;
292
-
structured_output;
293
-
unknown = Unknown.empty;
294
-
}
295
-
296
-
let make subtype duration_ms duration_api_ms is_error num_turns session_id
297
-
total_cost_usd usage result structured_output unknown =
298
-
{
299
-
subtype;
300
-
duration_ms;
301
-
duration_api_ms;
302
-
is_error;
303
-
num_turns;
304
-
session_id;
305
-
total_cost_usd;
306
-
usage;
307
-
result;
308
-
structured_output;
309
-
unknown;
310
-
}
311
-
312
-
let subtype t = t.subtype
313
-
let duration_ms t = t.duration_ms
314
-
let duration_api_ms t = t.duration_api_ms
315
-
let is_error t = t.is_error
316
-
let num_turns t = t.num_turns
317
-
let session_id t = t.session_id
318
-
let total_cost_usd t = t.total_cost_usd
319
-
let usage t = t.usage
320
-
let result t = t.result
321
-
let structured_output t = t.structured_output
322
-
let unknown t = t.unknown
323
-
324
-
let jsont : t Jsont.t =
325
-
Jsont.Object.map ~kind:"Result" make
326
-
|> Jsont.Object.mem "subtype" Jsont.string ~enc:subtype
327
-
|> Jsont.Object.mem "duration_ms" Jsont.int ~enc:duration_ms
328
-
|> Jsont.Object.mem "duration_api_ms" Jsont.int ~enc:duration_api_ms
329
-
|> Jsont.Object.mem "is_error" Jsont.bool ~enc:is_error
330
-
|> Jsont.Object.mem "num_turns" Jsont.int ~enc:num_turns
331
-
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
332
-
|> Jsont.Object.opt_mem "total_cost_usd" Jsont.number ~enc:total_cost_usd
333
-
|> Jsont.Object.opt_mem "usage" Usage.jsont ~enc:usage
334
-
|> Jsont.Object.opt_mem "result" Jsont.string ~enc:result
335
-
|> Jsont.Object.opt_mem "structured_output" Jsont.json
336
-
~enc:structured_output
337
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
338
-
|> Jsont.Object.finish
339
-
end
340
-
341
-
type t =
342
-
| User of User.t
343
-
| Assistant of Assistant.t
344
-
| System of System.t
345
-
| Result of Result.t
346
-
347
-
(* Jsont codec for the main Message variant type.
348
-
Uses case_mem for discriminated union based on "type" field. *)
349
-
let jsont : t Jsont.t =
350
-
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
351
-
let case_user = case_map "user" User.incoming_jsont (fun v -> User v) in
352
-
let case_assistant =
353
-
case_map "assistant" Assistant.incoming_jsont (fun v -> Assistant v)
354
-
in
355
-
let case_system = case_map "system" System.jsont (fun v -> System v) in
356
-
let case_result = case_map "result" Result.jsont (fun v -> Result v) in
357
-
let enc_case = function
358
-
| User v -> Jsont.Object.Case.value case_user v
359
-
| Assistant v -> Jsont.Object.Case.value case_assistant v
360
-
| System v -> Jsont.Object.Case.value case_system v
361
-
| Result v -> Jsont.Object.Case.value case_result v
362
-
in
363
-
let cases =
364
-
Jsont.Object.Case.
365
-
[
366
-
make case_user; make case_assistant; make case_system; make case_result;
367
-
]
368
-
in
369
-
Jsont.Object.map ~kind:"Message" Fun.id
370
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
371
-
~tag_to_string:Fun.id ~tag_compare:String.compare
372
-
|> 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
-276
proto/message.mli
-276
proto/message.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Messages exchanged with Claude wire format.
7
-
8
-
This module defines the wire format types for messages that can be sent to
9
-
and received from Claude, including user input, assistant responses, system
10
-
messages, and result metadata. *)
11
-
12
-
(** {1 User Messages} *)
13
-
14
-
module User : sig
15
-
(** Messages sent by the user. *)
16
-
17
-
(** The content of a user message. *)
18
-
type content =
19
-
| String of string (** Simple text message *)
20
-
| Blocks of Content_block.t list
21
-
(** Complex message with multiple content blocks *)
22
-
23
-
type t
24
-
(** The type of user messages. *)
25
-
26
-
val jsont : t Jsont.t
27
-
(** [jsont] is the Jsont codec for user messages. *)
28
-
29
-
val incoming_jsont : t Jsont.t
30
-
(** [incoming_jsont] is the codec for parsing incoming user messages from CLI.
31
-
This parses the envelope format with "message" wrapper. *)
32
-
33
-
val outgoing_jsont : t Jsont.t
34
-
(** [outgoing_jsont] is the codec for encoding outgoing user messages to CLI.
35
-
This produces the envelope format with "message" wrapper containing "role"
36
-
and "content" fields. *)
37
-
38
-
val create_string : string -> t
39
-
(** [create_string s] creates a user message with simple text content. *)
40
-
41
-
val create_blocks : Content_block.t list -> t
42
-
(** [create_blocks blocks] creates a user message with content blocks. *)
43
-
44
-
val create_with_tool_result :
45
-
tool_use_id:string -> content:Jsont.json -> ?is_error:bool -> unit -> t
46
-
(** [create_with_tool_result ~tool_use_id ~content ?is_error ()] creates a
47
-
user message containing a tool result. Content can be a string or array.
48
-
*)
49
-
50
-
val content : t -> content
51
-
(** [content t] returns the content of the user message. *)
52
-
53
-
val unknown : t -> Unknown.t
54
-
(** [unknown t] returns the unknown fields preserved from JSON. *)
55
-
end
56
-
57
-
(** {1 Assistant Messages} *)
58
-
59
-
module Assistant : sig
60
-
(** Messages from Claude assistant. *)
61
-
62
-
type error =
63
-
[ `Authentication_failed (** Authentication with Claude API failed *)
64
-
| `Billing_error (** Billing or account issue *)
65
-
| `Rate_limit (** Rate limit exceeded *)
66
-
| `Invalid_request (** Request was invalid *)
67
-
| `Server_error (** Internal server error *)
68
-
| `Unknown (** Unknown error type *) ]
69
-
(** The type of assistant message errors based on Python SDK error types. *)
70
-
71
-
type t
72
-
(** The type of assistant messages. *)
73
-
74
-
val jsont : t Jsont.t
75
-
(** [jsont] is the Jsont codec for assistant messages. *)
76
-
77
-
val incoming_jsont : t Jsont.t
78
-
(** [incoming_jsont] is the codec for parsing incoming assistant messages from
79
-
CLI. This parses the envelope format with "message" wrapper. *)
80
-
81
-
val create :
82
-
content:Content_block.t list -> model:string -> ?error:error -> unit -> t
83
-
(** [create ~content ~model ?error ()] creates an assistant message.
84
-
@param content List of content blocks in the response
85
-
@param model The model identifier used for the response
86
-
@param error Optional error that occurred during message generation *)
87
-
88
-
val content : t -> Content_block.t list
89
-
(** [content t] returns the content blocks of the assistant message. *)
90
-
91
-
val model : t -> string
92
-
(** [model t] returns the model identifier. *)
93
-
94
-
val error : t -> error option
95
-
(** [error t] returns the optional error that occurred during message
96
-
generation. *)
97
-
98
-
val unknown : t -> Unknown.t
99
-
(** [unknown t] returns the unknown fields preserved from JSON. *)
100
-
end
101
-
102
-
(** {1 System Messages} *)
103
-
104
-
module System : sig
105
-
(** System control and status messages.
106
-
107
-
System messages use a discriminated union on the "subtype" field:
108
-
- "init": Session initialization with session_id, model, cwd
109
-
- "error": Error messages with error string *)
110
-
111
-
type init = {
112
-
session_id : string option;
113
-
model : string option;
114
-
cwd : string option;
115
-
unknown : Unknown.t;
116
-
}
117
-
(** Init message fields. *)
118
-
119
-
type error = { error : string; unknown : Unknown.t }
120
-
(** Error message fields. *)
121
-
122
-
type t = Init of init | Error of error
123
-
124
-
val jsont : t Jsont.t
125
-
(** [jsont] is the Jsont codec for system messages. *)
126
-
127
-
(** {2 Constructors} *)
128
-
129
-
val init : ?session_id:string -> ?model:string -> ?cwd:string -> unit -> t
130
-
(** [init ?session_id ?model ?cwd ()] creates an init message. *)
131
-
132
-
val error : error:string -> t
133
-
(** [error ~error] creates an error message. *)
134
-
135
-
(** {2 Accessors} *)
136
-
137
-
val session_id : t -> string option
138
-
(** [session_id t] returns session_id from Init, None otherwise. *)
139
-
140
-
val model : t -> string option
141
-
(** [model t] returns model from Init, None otherwise. *)
142
-
143
-
val cwd : t -> string option
144
-
(** [cwd t] returns cwd from Init, None otherwise. *)
145
-
146
-
val error_msg : t -> string option
147
-
(** [error_msg t] returns error from Error, None otherwise. *)
148
-
149
-
val unknown : t -> Unknown.t
150
-
(** [unknown t] returns the unknown fields. *)
151
-
end
152
-
153
-
(** {1 Result Messages} *)
154
-
155
-
module Result : sig
156
-
(** Final result messages with metadata about the conversation. *)
157
-
158
-
module Usage : sig
159
-
(** Usage statistics for API calls. *)
160
-
161
-
type t
162
-
(** Type for usage statistics. *)
163
-
164
-
val jsont : t Jsont.t
165
-
(** [jsont] is the Jsont codec for usage statistics. *)
166
-
167
-
val create :
168
-
?input_tokens:int ->
169
-
?output_tokens:int ->
170
-
?total_tokens:int ->
171
-
?cache_creation_input_tokens:int ->
172
-
?cache_read_input_tokens:int ->
173
-
unit ->
174
-
t
175
-
(** [create ?input_tokens ?output_tokens ?total_tokens
176
-
?cache_creation_input_tokens ?cache_read_input_tokens ()] creates usage
177
-
statistics. *)
178
-
179
-
val input_tokens : t -> int option
180
-
(** [input_tokens t] returns the number of input tokens used. *)
181
-
182
-
val output_tokens : t -> int option
183
-
(** [output_tokens t] returns the number of output tokens generated. *)
184
-
185
-
val total_tokens : t -> int option
186
-
(** [total_tokens t] returns the total number of tokens. *)
187
-
188
-
val cache_creation_input_tokens : t -> int option
189
-
(** [cache_creation_input_tokens t] returns cache creation input tokens. *)
190
-
191
-
val cache_read_input_tokens : t -> int option
192
-
(** [cache_read_input_tokens t] returns cache read input tokens. *)
193
-
194
-
val unknown : t -> Unknown.t
195
-
(** [unknown t] returns the unknown fields preserved from JSON. *)
196
-
end
197
-
198
-
type t
199
-
(** The type of result messages. *)
200
-
201
-
val jsont : t Jsont.t
202
-
(** [jsont] is the Jsont codec for result messages. *)
203
-
204
-
val create :
205
-
subtype:string ->
206
-
duration_ms:int ->
207
-
duration_api_ms:int ->
208
-
is_error:bool ->
209
-
num_turns:int ->
210
-
session_id:string ->
211
-
?total_cost_usd:float ->
212
-
?usage:Usage.t ->
213
-
?result:string ->
214
-
?structured_output:Jsont.json ->
215
-
unit ->
216
-
t
217
-
(** [create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
218
-
~session_id ?total_cost_usd ?usage ?result ?structured_output ()] creates
219
-
a result message.
220
-
@param subtype The subtype of the result
221
-
@param duration_ms Total duration in milliseconds
222
-
@param duration_api_ms API duration in milliseconds
223
-
@param is_error Whether the result represents an error
224
-
@param num_turns Number of conversation turns
225
-
@param session_id Unique session identifier
226
-
@param total_cost_usd Optional total cost in USD
227
-
@param usage Optional usage statistics
228
-
@param result Optional result string
229
-
@param structured_output Optional structured JSON output from Claude *)
230
-
231
-
val subtype : t -> string
232
-
(** [subtype t] returns the subtype of the result. *)
233
-
234
-
val duration_ms : t -> int
235
-
(** [duration_ms t] returns the total duration in milliseconds. *)
236
-
237
-
val duration_api_ms : t -> int
238
-
(** [duration_api_ms t] returns the API duration in milliseconds. *)
239
-
240
-
val is_error : t -> bool
241
-
(** [is_error t] returns whether this result represents an error. *)
242
-
243
-
val num_turns : t -> int
244
-
(** [num_turns t] returns the number of conversation turns. *)
245
-
246
-
val session_id : t -> string
247
-
(** [session_id t] returns the session identifier. *)
248
-
249
-
val total_cost_usd : t -> float option
250
-
(** [total_cost_usd t] returns the optional total cost in USD. *)
251
-
252
-
val usage : t -> Usage.t option
253
-
(** [usage t] returns the optional usage statistics. *)
254
-
255
-
val result : t -> string option
256
-
(** [result t] returns the optional result string. *)
257
-
258
-
val structured_output : t -> Jsont.json option
259
-
(** [structured_output t] returns the optional structured JSON output. *)
260
-
261
-
val unknown : t -> Unknown.t
262
-
(** [unknown t] returns the unknown fields preserved from JSON. *)
263
-
end
264
-
265
-
(** {1 Message Union Type} *)
266
-
267
-
type t =
268
-
| User of User.t
269
-
| Assistant of Assistant.t
270
-
| System of System.t
271
-
| Result of Result.t
272
-
(** The type of messages, which can be user, assistant, system, or result.
273
-
*)
274
-
275
-
val jsont : t Jsont.t
276
-
(** [jsont] is the Jsont codec for messages. *)
-37
proto/model.ml
-37
proto/model.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
type t =
7
-
[ `Sonnet_4_5
8
-
| `Sonnet_4
9
-
| `Sonnet_3_5
10
-
| `Opus_4_5
11
-
| `Opus_4_1
12
-
| `Opus_4
13
-
| `Haiku_4
14
-
| `Custom of string ]
15
-
16
-
let to_string = function
17
-
| `Sonnet_4_5 -> "claude-sonnet-4-5"
18
-
| `Sonnet_4 -> "claude-sonnet-4"
19
-
| `Sonnet_3_5 -> "claude-sonnet-3-5"
20
-
| `Opus_4_5 -> "claude-opus-4-5"
21
-
| `Opus_4_1 -> "claude-opus-4-1"
22
-
| `Opus_4 -> "claude-opus-4"
23
-
| `Haiku_4 -> "claude-haiku-4"
24
-
| `Custom s -> s
25
-
26
-
let of_string = function
27
-
| "claude-sonnet-4-5" -> `Sonnet_4_5
28
-
| "claude-sonnet-4" -> `Sonnet_4
29
-
| "claude-sonnet-3-5" -> `Sonnet_3_5
30
-
| "claude-opus-4-5" -> `Opus_4_5
31
-
| "claude-opus-4-1" -> `Opus_4_1
32
-
| "claude-opus-4" -> `Opus_4
33
-
| "claude-haiku-4" -> `Haiku_4
34
-
| s -> `Custom s
35
-
36
-
let jsont : t Jsont.t =
37
-
Jsont.map ~kind:"Model" ~dec:of_string ~enc:to_string Jsont.string
-46
proto/model.mli
-46
proto/model.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Claude AI model identifiers for protocol encoding.
7
-
8
-
This module provides type-safe model identifiers with JSON encoding/decoding
9
-
support via Jsont. Use polymorphic variants for known models with a custom
10
-
escape hatch for future or unknown models. *)
11
-
12
-
type t =
13
-
[ `Sonnet_4_5 (** claude-sonnet-4-5 - Most recent Sonnet model *)
14
-
| `Sonnet_4 (** claude-sonnet-4 - Sonnet 4 model *)
15
-
| `Sonnet_3_5 (** claude-sonnet-3-5 - Sonnet 3.5 model *)
16
-
| `Opus_4_5 (** claude-opus-4-5 - Most recent Opus model *)
17
-
| `Opus_4_1 (** claude-opus-4-1 - Opus 4.1 model *)
18
-
| `Opus_4 (** claude-opus-4 - Opus 4 model for complex tasks *)
19
-
| `Haiku_4 (** claude-haiku-4 - Fast, cost-effective Haiku model *)
20
-
| `Custom of string (** Custom model string for future/unknown models *) ]
21
-
(** The type of Claude models. *)
22
-
23
-
val to_string : t -> string
24
-
(** [to_string t] converts a model to its string representation.
25
-
26
-
Examples:
27
-
- [`Sonnet_4_5] becomes "claude-sonnet-4-5"
28
-
- [`Opus_4_5] becomes "claude-opus-4-5"
29
-
- [`Opus_4] becomes "claude-opus-4"
30
-
- [`Custom "my-model"] becomes "my-model" *)
31
-
32
-
val of_string : string -> t
33
-
(** [of_string s] parses a model string into a typed model.
34
-
35
-
Known model strings are converted to their typed variants. Unknown strings
36
-
become [`Custom s].
37
-
38
-
Examples:
39
-
- "claude-sonnet-4-5" becomes [`Sonnet_4_5]
40
-
- "future-model" becomes [`Custom "future-model"] *)
41
-
42
-
val jsont : t Jsont.t
43
-
(** [jsont] is the Jsont codec for model identifiers.
44
-
45
-
This codec maps between the typed model representation and JSON strings. It
46
-
uses [of_string] for decoding and [to_string] for encoding. *)
-191
proto/options.ml
-191
proto/options.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Wire format for Claude configuration options. *)
7
-
8
-
(** Setting sources *)
9
-
type setting_source = User | Project | Local
10
-
11
-
let setting_source_jsont : setting_source Jsont.t =
12
-
Jsont.enum [ ("user", User); ("project", Project); ("local", Local) ]
13
-
14
-
type t = {
15
-
allowed_tools : string list;
16
-
disallowed_tools : string list;
17
-
max_thinking_tokens : int option;
18
-
system_prompt : string option;
19
-
append_system_prompt : string option;
20
-
permission_mode : Permissions.Mode.t option;
21
-
model : Model.t option;
22
-
continue_conversation : bool;
23
-
resume : string option;
24
-
max_turns : int option;
25
-
permission_prompt_tool_name : string option;
26
-
settings : string option;
27
-
add_dirs : string list;
28
-
max_budget_usd : float option;
29
-
fallback_model : Model.t option;
30
-
setting_sources : setting_source list option;
31
-
max_buffer_size : int option;
32
-
user : string option;
33
-
output_format : Structured_output.t option;
34
-
unknown : Unknown.t;
35
-
}
36
-
(** Configuration type *)
37
-
38
-
let empty =
39
-
{
40
-
allowed_tools = [];
41
-
disallowed_tools = [];
42
-
max_thinking_tokens = None;
43
-
system_prompt = None;
44
-
append_system_prompt = None;
45
-
permission_mode = None;
46
-
model = None;
47
-
continue_conversation = false;
48
-
resume = None;
49
-
max_turns = None;
50
-
permission_prompt_tool_name = None;
51
-
settings = None;
52
-
add_dirs = [];
53
-
max_budget_usd = None;
54
-
fallback_model = None;
55
-
setting_sources = None;
56
-
max_buffer_size = None;
57
-
user = None;
58
-
output_format = None;
59
-
unknown = Unknown.empty;
60
-
}
61
-
62
-
(** Accessor functions *)
63
-
let allowed_tools t = t.allowed_tools
64
-
65
-
let disallowed_tools t = t.disallowed_tools
66
-
let max_thinking_tokens t = t.max_thinking_tokens
67
-
let system_prompt t = t.system_prompt
68
-
let append_system_prompt t = t.append_system_prompt
69
-
let permission_mode t = t.permission_mode
70
-
let model t = t.model
71
-
let continue_conversation t = t.continue_conversation
72
-
let resume t = t.resume
73
-
let max_turns t = t.max_turns
74
-
let permission_prompt_tool_name t = t.permission_prompt_tool_name
75
-
let settings t = t.settings
76
-
let add_dirs t = t.add_dirs
77
-
let max_budget_usd t = t.max_budget_usd
78
-
let fallback_model t = t.fallback_model
79
-
let setting_sources t = t.setting_sources
80
-
let max_buffer_size t = t.max_buffer_size
81
-
let user t = t.user
82
-
let output_format t = t.output_format
83
-
let unknown t = t.unknown
84
-
85
-
(** Builder functions *)
86
-
let with_allowed_tools allowed_tools t = { t with allowed_tools }
87
-
88
-
let with_disallowed_tools disallowed_tools t = { t with disallowed_tools }
89
-
90
-
let with_max_thinking_tokens max_thinking_tokens t =
91
-
{ t with max_thinking_tokens = Some max_thinking_tokens }
92
-
93
-
let with_system_prompt system_prompt t =
94
-
{ t with system_prompt = Some system_prompt }
95
-
96
-
let with_append_system_prompt append_system_prompt t =
97
-
{ t with append_system_prompt = Some append_system_prompt }
98
-
99
-
let with_permission_mode permission_mode t =
100
-
{ t with permission_mode = Some permission_mode }
101
-
102
-
let with_model model t = { t with model = Some model }
103
-
104
-
let with_continue_conversation continue_conversation t =
105
-
{ t with continue_conversation }
106
-
107
-
let with_resume resume t = { t with resume = Some resume }
108
-
let with_max_turns max_turns t = { t with max_turns = Some max_turns }
109
-
110
-
let with_permission_prompt_tool_name permission_prompt_tool_name t =
111
-
{ t with permission_prompt_tool_name = Some permission_prompt_tool_name }
112
-
113
-
let with_settings settings t = { t with settings = Some settings }
114
-
let with_add_dirs add_dirs t = { t with add_dirs }
115
-
116
-
let with_max_budget_usd max_budget_usd t =
117
-
{ t with max_budget_usd = Some max_budget_usd }
118
-
119
-
let with_fallback_model fallback_model t =
120
-
{ t with fallback_model = Some fallback_model }
121
-
122
-
let with_setting_sources setting_sources t =
123
-
{ t with setting_sources = Some setting_sources }
124
-
125
-
let with_max_buffer_size max_buffer_size t =
126
-
{ t with max_buffer_size = Some max_buffer_size }
127
-
128
-
let with_user user t = { t with user = Some user }
129
-
130
-
let with_output_format output_format t =
131
-
{ t with output_format = Some output_format }
132
-
133
-
(** JSON codec *)
134
-
let jsont : t Jsont.t =
135
-
let make allowed_tools disallowed_tools max_thinking_tokens system_prompt
136
-
append_system_prompt permission_mode model continue_conversation resume
137
-
max_turns permission_prompt_tool_name settings add_dirs max_budget_usd
138
-
fallback_model setting_sources max_buffer_size user output_format unknown
139
-
=
140
-
{
141
-
allowed_tools;
142
-
disallowed_tools;
143
-
max_thinking_tokens;
144
-
system_prompt;
145
-
append_system_prompt;
146
-
permission_mode;
147
-
model;
148
-
continue_conversation;
149
-
resume;
150
-
max_turns;
151
-
permission_prompt_tool_name;
152
-
settings;
153
-
add_dirs;
154
-
max_budget_usd;
155
-
fallback_model;
156
-
setting_sources;
157
-
max_buffer_size;
158
-
user;
159
-
output_format;
160
-
unknown;
161
-
}
162
-
in
163
-
Jsont.Object.(
164
-
map ~kind:"Options" make
165
-
|> mem "allowedTools" (Jsont.list Jsont.string) ~enc:allowed_tools
166
-
~dec_absent:[]
167
-
|> mem "disallowedTools" (Jsont.list Jsont.string) ~enc:disallowed_tools
168
-
~dec_absent:[]
169
-
|> opt_mem "maxThinkingTokens" Jsont.int ~enc:max_thinking_tokens
170
-
|> opt_mem "systemPrompt" Jsont.string ~enc:system_prompt
171
-
|> opt_mem "appendSystemPrompt" Jsont.string ~enc:append_system_prompt
172
-
|> opt_mem "permissionMode" Permissions.Mode.jsont ~enc:permission_mode
173
-
|> opt_mem "model" Model.jsont ~enc:model
174
-
|> mem "continueConversation" Jsont.bool ~enc:continue_conversation
175
-
~dec_absent:false
176
-
|> opt_mem "resume" Jsont.string ~enc:resume
177
-
|> opt_mem "maxTurns" Jsont.int ~enc:max_turns
178
-
|> opt_mem "permissionPromptToolName" Jsont.string
179
-
~enc:permission_prompt_tool_name
180
-
|> opt_mem "settings" Jsont.string ~enc:settings
181
-
|> mem "addDirs" (Jsont.list Jsont.string) ~enc:add_dirs ~dec_absent:[]
182
-
|> opt_mem "maxBudgetUsd" Jsont.number ~enc:max_budget_usd
183
-
|> opt_mem "fallbackModel" Model.jsont ~enc:fallback_model
184
-
|> opt_mem "settingSources"
185
-
(Jsont.list setting_source_jsont)
186
-
~enc:setting_sources
187
-
|> opt_mem "maxBufferSize" Jsont.int ~enc:max_buffer_size
188
-
|> opt_mem "user" Jsont.string ~enc:user
189
-
|> opt_mem "outputFormat" Structured_output.jsont ~enc:output_format
190
-
|> keep_unknown Unknown.mems ~enc:unknown
191
-
|> finish)
-197
proto/options.mli
-197
proto/options.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Wire format for Claude configuration options.
7
-
8
-
This module provides the protocol-level wire format encoding/decoding for
9
-
configuration options used in JSON configuration files. It handles JSON
10
-
serialization and deserialization with proper field name mappings
11
-
(camelCase).
12
-
13
-
This is the protocol-level module without Eio types or logging. *)
14
-
15
-
(** {1 Setting Sources} *)
16
-
17
-
(** The type of setting sources, indicating where configuration was loaded from.
18
-
*)
19
-
type setting_source =
20
-
| User (** User-level settings *)
21
-
| Project (** Project-level settings *)
22
-
| Local (** Local directory settings *)
23
-
24
-
(** {1 Configuration Type} *)
25
-
26
-
type t
27
-
(** The type of configuration options.
28
-
29
-
This represents all configurable options for Claude interactions, encoded in
30
-
JSON format. *)
31
-
32
-
val jsont : t Jsont.t
33
-
(** [jsont] is the Jsont codec for configuration options.
34
-
35
-
Wire format uses camelCase field names:
36
-
- allowedTools (array of strings)
37
-
- disallowedTools (array of strings)
38
-
- maxThinkingTokens (int)
39
-
- systemPrompt (string)
40
-
- appendSystemPrompt (string)
41
-
- permissionMode (string via Permissions.Mode.jsont)
42
-
- model (string via Model.jsont)
43
-
- continueConversation (bool)
44
-
- resume (string)
45
-
- maxTurns (int)
46
-
- permissionPromptToolName (string)
47
-
- settings (string)
48
-
- addDirs (array of strings)
49
-
- maxBudgetUsd (float)
50
-
- fallbackModel (string via Model.jsont)
51
-
- settingSources (array of "user", "project", "local")
52
-
- maxBufferSize (int)
53
-
- user (string)
54
-
- outputFormat (object via Structured_output.jsont)
55
-
56
-
Unknown fields are preserved for forward compatibility. *)
57
-
58
-
val empty : t
59
-
(** [empty] is an empty configuration with all fields set to their default
60
-
values.
61
-
62
-
Default values:
63
-
- Lists default to empty
64
-
- [maxThinkingTokens] defaults to 8000
65
-
- [continueConversation] defaults to false
66
-
- All optional fields default to [None] *)
67
-
68
-
(** {1 Accessor Functions} *)
69
-
70
-
val allowed_tools : t -> string list
71
-
(** [allowed_tools t] returns the list of allowed tool names. Empty list means
72
-
all tools are allowed (unless explicitly disallowed). *)
73
-
74
-
val disallowed_tools : t -> string list
75
-
(** [disallowed_tools t] returns the list of disallowed tool names. *)
76
-
77
-
val max_thinking_tokens : t -> int option
78
-
(** [max_thinking_tokens t] returns the maximum number of tokens Claude can use
79
-
for internal thinking. *)
80
-
81
-
val system_prompt : t -> string option
82
-
(** [system_prompt t] returns the system prompt to use for Claude. *)
83
-
84
-
val append_system_prompt : t -> string option
85
-
(** [append_system_prompt t] returns additional text to append to the system
86
-
prompt. *)
87
-
88
-
val permission_mode : t -> Permissions.Mode.t option
89
-
(** [permission_mode t] returns the permission mode controlling how tool
90
-
invocations are authorized. *)
91
-
92
-
val model : t -> Model.t option
93
-
(** [model t] returns the Claude model to use for interactions. *)
94
-
95
-
val continue_conversation : t -> bool
96
-
(** [continue_conversation t] returns whether to continue from a previous
97
-
conversation. *)
98
-
99
-
val resume : t -> string option
100
-
(** [resume t] returns the session ID to resume from. *)
101
-
102
-
val max_turns : t -> int option
103
-
(** [max_turns t] returns the maximum number of conversation turns to allow. *)
104
-
105
-
val permission_prompt_tool_name : t -> string option
106
-
(** [permission_prompt_tool_name t] returns the tool name to use for permission
107
-
prompts. *)
108
-
109
-
val settings : t -> string option
110
-
(** [settings t] returns the path to the settings file. *)
111
-
112
-
val add_dirs : t -> string list
113
-
(** [add_dirs t] returns additional directories to include in the context. *)
114
-
115
-
val max_budget_usd : t -> float option
116
-
(** [max_budget_usd t] returns the maximum budget in USD for API calls. *)
117
-
118
-
val fallback_model : t -> Model.t option
119
-
(** [fallback_model t] returns the fallback model to use if the primary model
120
-
fails. *)
121
-
122
-
val setting_sources : t -> setting_source list option
123
-
(** [setting_sources t] returns the list of setting sources to load from. *)
124
-
125
-
val max_buffer_size : t -> int option
126
-
(** [max_buffer_size t] returns the maximum buffer size for I/O operations. *)
127
-
128
-
val user : t -> string option
129
-
(** [user t] returns the user identifier for the session. *)
130
-
131
-
val output_format : t -> Structured_output.t option
132
-
(** [output_format t] returns the structured output format configuration. *)
133
-
134
-
val unknown : t -> Unknown.t
135
-
(** [unknown t] returns the unknown fields preserved from JSON parsing. *)
136
-
137
-
(** {1 Builder Functions} *)
138
-
139
-
val with_allowed_tools : string list -> t -> t
140
-
(** [with_allowed_tools tools t] sets the allowed tools. *)
141
-
142
-
val with_disallowed_tools : string list -> t -> t
143
-
(** [with_disallowed_tools tools t] sets the disallowed tools. *)
144
-
145
-
val with_max_thinking_tokens : int -> t -> t
146
-
(** [with_max_thinking_tokens tokens t] sets the maximum thinking tokens. *)
147
-
148
-
val with_system_prompt : string -> t -> t
149
-
(** [with_system_prompt prompt t] sets the system prompt. *)
150
-
151
-
val with_append_system_prompt : string -> t -> t
152
-
(** [with_append_system_prompt prompt t] sets the text to append to the system
153
-
prompt. *)
154
-
155
-
val with_permission_mode : Permissions.Mode.t -> t -> t
156
-
(** [with_permission_mode mode t] sets the permission mode. *)
157
-
158
-
val with_model : Model.t -> t -> t
159
-
(** [with_model model t] sets the Claude model. *)
160
-
161
-
val with_continue_conversation : bool -> t -> t
162
-
(** [with_continue_conversation continue t] sets whether to continue
163
-
conversation. *)
164
-
165
-
val with_resume : string -> t -> t
166
-
(** [with_resume session_id t] sets the session ID to resume from. *)
167
-
168
-
val with_max_turns : int -> t -> t
169
-
(** [with_max_turns turns t] sets the maximum number of turns. *)
170
-
171
-
val with_permission_prompt_tool_name : string -> t -> t
172
-
(** [with_permission_prompt_tool_name tool t] sets the permission prompt tool
173
-
name. *)
174
-
175
-
val with_settings : string -> t -> t
176
-
(** [with_settings path t] sets the settings file path. *)
177
-
178
-
val with_add_dirs : string list -> t -> t
179
-
(** [with_add_dirs dirs t] sets the additional directories. *)
180
-
181
-
val with_max_budget_usd : float -> t -> t
182
-
(** [with_max_budget_usd budget t] sets the maximum budget. *)
183
-
184
-
val with_fallback_model : Model.t -> t -> t
185
-
(** [with_fallback_model model t] sets the fallback model. *)
186
-
187
-
val with_setting_sources : setting_source list -> t -> t
188
-
(** [with_setting_sources sources t] sets the setting sources. *)
189
-
190
-
val with_max_buffer_size : int -> t -> t
191
-
(** [with_max_buffer_size size t] sets the maximum buffer size. *)
192
-
193
-
val with_user : string -> t -> t
194
-
(** [with_user user t] sets the user identifier. *)
195
-
196
-
val with_output_format : Structured_output.t -> t -> t
197
-
(** [with_output_format format t] sets the structured output format. *)
-82
proto/outgoing.ml
-82
proto/outgoing.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Outgoing messages to Claude CLI.
7
-
8
-
This uses the Message.jsont for conversation messages and Control envelope
9
-
codecs for control messages. The top-level discriminator is the "type"
10
-
field. *)
11
-
12
-
type t =
13
-
| Message of Message.t
14
-
| Control_request of Control.request_envelope
15
-
| Control_response of Control.response_envelope
16
-
17
-
let jsont : t Jsont.t =
18
-
(* Message types use "user", "assistant", "system", "result" as type values.
19
-
Control uses "control_request" and "control_response".
20
-
21
-
We use case_mem for all types. For Message, we use Message.jsont which
22
-
already handles the inner "type" discrimination. *)
23
-
let case_control_request =
24
-
Jsont.Object.Case.map "control_request" Control.request_envelope_jsont
25
-
~dec:(fun v -> Control_request v)
26
-
in
27
-
let case_control_response =
28
-
Jsont.Object.Case.map "control_response" Control.response_envelope_jsont
29
-
~dec:(fun v -> Control_response v)
30
-
in
31
-
(* For messages, we need to handle all four message types *)
32
-
let case_user =
33
-
Jsont.Object.Case.map "user" Message.User.outgoing_jsont ~dec:(fun v ->
34
-
Message (Message.User v))
35
-
in
36
-
let case_assistant =
37
-
Jsont.Object.Case.map "assistant" Message.Assistant.jsont ~dec:(fun v ->
38
-
Message (Message.Assistant v))
39
-
in
40
-
let case_system =
41
-
Jsont.Object.Case.map "system" Message.System.jsont ~dec:(fun v ->
42
-
Message (Message.System v))
43
-
in
44
-
let case_result =
45
-
Jsont.Object.Case.map "result" Message.Result.jsont ~dec:(fun v ->
46
-
Message (Message.Result v))
47
-
in
48
-
let enc_case = function
49
-
| Control_request v -> Jsont.Object.Case.value case_control_request v
50
-
| Control_response v -> Jsont.Object.Case.value case_control_response v
51
-
| Message msg -> (
52
-
match msg with
53
-
| Message.User u -> Jsont.Object.Case.value case_user u
54
-
| Message.Assistant a -> Jsont.Object.Case.value case_assistant a
55
-
| Message.System s -> Jsont.Object.Case.value case_system s
56
-
| Message.Result r -> Jsont.Object.Case.value case_result r)
57
-
in
58
-
let cases =
59
-
Jsont.Object.Case.
60
-
[
61
-
make case_control_request;
62
-
make case_control_response;
63
-
make case_user;
64
-
make case_assistant;
65
-
make case_system;
66
-
make case_result;
67
-
]
68
-
in
69
-
Jsont.Object.map ~kind:"Outgoing" Fun.id
70
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
71
-
~tag_to_string:Fun.id ~tag_compare:String.compare
72
-
|> Jsont.Object.finish
73
-
74
-
let to_json t =
75
-
match Jsont.Json.encode jsont t with
76
-
| Ok json -> json
77
-
| Error e -> invalid_arg ("to_json: " ^ e)
78
-
79
-
let of_json json =
80
-
match Jsont.Json.decode jsont json with
81
-
| Ok v -> v
82
-
| Error e -> invalid_arg ("of_json: " ^ e)
-24
proto/outgoing.mli
-24
proto/outgoing.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Outgoing messages to the Claude CLI.
7
-
8
-
This module provides encoding for all message types that can be sent to the
9
-
Claude CLI. *)
10
-
11
-
type t =
12
-
| Message of Message.t
13
-
| Control_request of Control.request_envelope
14
-
| Control_response of Control.response_envelope
15
-
16
-
val jsont : t Jsont.t
17
-
(** Codec for outgoing messages. *)
18
-
19
-
val to_json : t -> Jsont.json
20
-
(** [to_json t] converts an outgoing message to JSON. *)
21
-
22
-
val of_json : Jsont.json -> t
23
-
(** [of_json json] parses an outgoing message from JSON.
24
-
@raise Invalid_argument if parsing fails. *)
-248
proto/permissions.ml
-248
proto/permissions.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Permission system wire format for Claude tool invocations.
7
-
8
-
This module provides the wire format encoding/decoding for permission types
9
-
used in the Claude protocol. It handles JSON serialization and
10
-
deserialization with proper field name mappings. *)
11
-
12
-
(** Permission modes *)
13
-
module Mode = struct
14
-
type t = Default | Accept_edits | Plan | Bypass_permissions
15
-
16
-
let to_string = function
17
-
| Default -> "default"
18
-
| Accept_edits -> "acceptEdits"
19
-
| Plan -> "plan"
20
-
| Bypass_permissions -> "bypassPermissions"
21
-
22
-
let of_string = function
23
-
| "default" -> Default
24
-
| "acceptEdits" -> Accept_edits
25
-
| "plan" -> Plan
26
-
| "bypassPermissions" -> Bypass_permissions
27
-
| s ->
28
-
raise
29
-
(Invalid_argument (Printf.sprintf "Mode.of_string: unknown mode %s" s))
30
-
31
-
let jsont : t Jsont.t =
32
-
Jsont.enum
33
-
[
34
-
("default", Default);
35
-
("acceptEdits", Accept_edits);
36
-
("plan", Plan);
37
-
("bypassPermissions", Bypass_permissions);
38
-
]
39
-
end
40
-
41
-
(** Permission behaviors *)
42
-
module Behavior = struct
43
-
type t = Allow | Deny | Ask
44
-
45
-
let to_string = function Allow -> "allow" | Deny -> "deny" | Ask -> "ask"
46
-
47
-
let of_string = function
48
-
| "allow" -> Allow
49
-
| "deny" -> Deny
50
-
| "ask" -> Ask
51
-
| s ->
52
-
raise
53
-
(Invalid_argument
54
-
(Printf.sprintf "Behavior.of_string: unknown behavior %s" s))
55
-
56
-
let jsont : t Jsont.t =
57
-
Jsont.enum [ ("allow", Allow); ("deny", Deny); ("ask", Ask) ]
58
-
end
59
-
60
-
(** Permission rules *)
61
-
module Rule = struct
62
-
type t = {
63
-
tool_name : string;
64
-
rule_content : string option;
65
-
unknown : Unknown.t;
66
-
}
67
-
68
-
let create ~tool_name ?rule_content ?(unknown = Unknown.empty) () =
69
-
{ tool_name; rule_content; unknown }
70
-
71
-
let tool_name t = t.tool_name
72
-
let rule_content t = t.rule_content
73
-
let unknown t = t.unknown
74
-
75
-
let jsont : t Jsont.t =
76
-
let make tool_name rule_content unknown =
77
-
{ tool_name; rule_content; unknown }
78
-
in
79
-
Jsont.Object.map ~kind:"Rule" make
80
-
|> Jsont.Object.mem "toolName" Jsont.string ~enc:tool_name
81
-
|> Jsont.Object.opt_mem "ruleContent" Jsont.string ~enc:rule_content
82
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
83
-
|> Jsont.Object.finish
84
-
end
85
-
86
-
(** Permission updates *)
87
-
module Update = struct
88
-
type destination =
89
-
| User_settings
90
-
| Project_settings
91
-
| Local_settings
92
-
| Session
93
-
94
-
let destination_jsont : destination Jsont.t =
95
-
Jsont.enum
96
-
[
97
-
("userSettings", User_settings);
98
-
("projectSettings", Project_settings);
99
-
("localSettings", Local_settings);
100
-
("session", Session);
101
-
]
102
-
103
-
type update_type =
104
-
| Add_rules
105
-
| Replace_rules
106
-
| Remove_rules
107
-
| Set_mode
108
-
| Add_directories
109
-
| Remove_directories
110
-
111
-
let update_type_jsont : update_type Jsont.t =
112
-
Jsont.enum
113
-
[
114
-
("addRules", Add_rules);
115
-
("replaceRules", Replace_rules);
116
-
("removeRules", Remove_rules);
117
-
("setMode", Set_mode);
118
-
("addDirectories", Add_directories);
119
-
("removeDirectories", Remove_directories);
120
-
]
121
-
122
-
type t = {
123
-
update_type : update_type;
124
-
rules : Rule.t list option;
125
-
behavior : Behavior.t option;
126
-
mode : Mode.t option;
127
-
directories : string list option;
128
-
destination : destination option;
129
-
unknown : Unknown.t;
130
-
}
131
-
132
-
let create ~update_type ?rules ?behavior ?mode ?directories ?destination
133
-
?(unknown = Unknown.empty) () =
134
-
{ update_type; rules; behavior; mode; directories; destination; unknown }
135
-
136
-
let update_type t = t.update_type
137
-
let rules t = t.rules
138
-
let behavior t = t.behavior
139
-
let mode t = t.mode
140
-
let directories t = t.directories
141
-
let destination t = t.destination
142
-
let unknown t = t.unknown
143
-
144
-
let jsont : t Jsont.t =
145
-
let make update_type rules behavior mode directories destination unknown =
146
-
{ update_type; rules; behavior; mode; directories; destination; unknown }
147
-
in
148
-
Jsont.Object.map ~kind:"Update" make
149
-
|> Jsont.Object.mem "type" update_type_jsont ~enc:update_type
150
-
|> Jsont.Object.opt_mem "rules" (Jsont.list Rule.jsont) ~enc:rules
151
-
|> Jsont.Object.opt_mem "behavior" Behavior.jsont ~enc:behavior
152
-
|> Jsont.Object.opt_mem "mode" Mode.jsont ~enc:mode
153
-
|> Jsont.Object.opt_mem "directories" (Jsont.list Jsont.string)
154
-
~enc:directories
155
-
|> Jsont.Object.opt_mem "destination" destination_jsont ~enc:destination
156
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
157
-
|> Jsont.Object.finish
158
-
end
159
-
160
-
(** Permission context for callbacks *)
161
-
module Context = struct
162
-
type t = { suggestions : Update.t list; unknown : Unknown.t }
163
-
164
-
let create ?(suggestions = []) ?(unknown = Unknown.empty) () =
165
-
{ suggestions; unknown }
166
-
167
-
let suggestions t = t.suggestions
168
-
let unknown t = t.unknown
169
-
170
-
let jsont : t Jsont.t =
171
-
let make suggestions unknown = { suggestions; unknown } in
172
-
Jsont.Object.map ~kind:"Context" make
173
-
|> Jsont.Object.mem "suggestions" (Jsont.list Update.jsont) ~enc:suggestions
174
-
~dec_absent:[]
175
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
176
-
|> Jsont.Object.finish
177
-
end
178
-
179
-
(** Permission results *)
180
-
module Result = struct
181
-
type t =
182
-
| Allow of {
183
-
updated_input : Jsont.json option;
184
-
updated_permissions : Update.t list option;
185
-
unknown : Unknown.t;
186
-
}
187
-
| Deny of { message : string; interrupt : bool; unknown : Unknown.t }
188
-
189
-
let allow ?updated_input ?updated_permissions ?(unknown = Unknown.empty) () =
190
-
Allow { updated_input; updated_permissions; unknown }
191
-
192
-
let deny ~message ~interrupt ?(unknown = Unknown.empty) () =
193
-
Deny { message; interrupt; unknown }
194
-
195
-
let jsont : t Jsont.t =
196
-
let allow_record =
197
-
let make updated_input updated_permissions unknown =
198
-
Allow { updated_input; updated_permissions; unknown }
199
-
in
200
-
Jsont.Object.map ~kind:"AllowRecord" make
201
-
|> Jsont.Object.mem "updatedInput" (Jsont.option Jsont.json)
202
-
~enc:(function
203
-
| Allow { updated_input; _ } -> updated_input | _ -> None)
204
-
~dec_absent:None
205
-
|> Jsont.Object.opt_mem "updatedPermissions" (Jsont.list Update.jsont)
206
-
~enc:(function
207
-
| Allow { updated_permissions; _ } -> updated_permissions
208
-
| _ -> None)
209
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(function
210
-
| Allow { unknown; _ } -> unknown
211
-
| _ -> Unknown.empty)
212
-
|> Jsont.Object.finish
213
-
in
214
-
let deny_record =
215
-
let make message interrupt unknown =
216
-
Deny { message; interrupt; unknown }
217
-
in
218
-
Jsont.Object.map ~kind:"DenyRecord" make
219
-
|> Jsont.Object.mem "message" Jsont.string ~enc:(function
220
-
| Deny { message; _ } -> message
221
-
| _ -> "")
222
-
|> Jsont.Object.mem "interrupt" Jsont.bool ~enc:(function
223
-
| Deny { interrupt; _ } -> interrupt
224
-
| _ -> false)
225
-
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(function
226
-
| Deny { unknown; _ } -> unknown
227
-
| _ -> Unknown.empty)
228
-
|> Jsont.Object.finish
229
-
in
230
-
let case_allow =
231
-
Jsont.Object.Case.map "allow" allow_record ~dec:(fun v -> v)
232
-
in
233
-
let case_deny =
234
-
Jsont.Object.Case.map "deny" deny_record ~dec:(fun v -> v)
235
-
in
236
-
237
-
let enc_case = function
238
-
| Allow _ as v -> Jsont.Object.Case.value case_allow v
239
-
| Deny _ as v -> Jsont.Object.Case.value case_deny v
240
-
in
241
-
242
-
let cases = Jsont.Object.Case.[ make case_allow; make case_deny ] in
243
-
244
-
Jsont.Object.map ~kind:"Result" Fun.id
245
-
|> Jsont.Object.case_mem "behavior" Jsont.string ~enc:Fun.id ~enc_case cases
246
-
~tag_to_string:Fun.id ~tag_compare:String.compare
247
-
|> Jsont.Object.finish
248
-
end
-227
proto/permissions.mli
-227
proto/permissions.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Permission system wire format for Claude tool invocations.
7
-
8
-
This module provides the wire format encoding/decoding for permission types
9
-
used in the Claude protocol. It handles JSON serialization and
10
-
deserialization with proper field name mappings. *)
11
-
12
-
(** {1 Permission Modes} *)
13
-
14
-
module Mode : sig
15
-
(** Permission modes control the overall behavior of the permission system. *)
16
-
17
-
(** The type of permission modes. *)
18
-
type t =
19
-
| Default (** Standard permission mode with normal checks *)
20
-
| Accept_edits (** Automatically accept file edits *)
21
-
| Plan (** Planning mode with restricted execution *)
22
-
| Bypass_permissions (** Bypass all permission checks *)
23
-
24
-
val jsont : t Jsont.t
25
-
(** [jsont] is the Jsont codec for permission modes. Wire format uses
26
-
camelCase: "default", "acceptEdits", "plan", "bypassPermissions". *)
27
-
28
-
val to_string : t -> string
29
-
(** [to_string t] converts a mode to its wire format string representation. *)
30
-
31
-
val of_string : string -> t
32
-
(** [of_string s] parses a mode from its wire format string representation.
33
-
@raise Invalid_argument if the string is not a valid mode. *)
34
-
end
35
-
36
-
(** {1 Permission Behaviors} *)
37
-
38
-
module Behavior : sig
39
-
(** Behaviors determine how permission requests are handled. *)
40
-
41
-
(** The type of permission behaviors. *)
42
-
type t =
43
-
| Allow (** Allow the operation *)
44
-
| Deny (** Deny the operation *)
45
-
| Ask (** Ask the user for permission *)
46
-
47
-
val jsont : t Jsont.t
48
-
(** [jsont] is the Jsont codec for permission behaviors. Wire format uses
49
-
lowercase: "allow", "deny", "ask". *)
50
-
51
-
val to_string : t -> string
52
-
(** [to_string t] converts a behavior to its wire format string
53
-
representation. *)
54
-
55
-
val of_string : string -> t
56
-
(** [of_string s] parses a behavior from its wire format string
57
-
representation.
58
-
@raise Invalid_argument if the string is not a valid behavior. *)
59
-
end
60
-
61
-
(** {1 Permission Rules} *)
62
-
63
-
module Rule : sig
64
-
(** Rules define specific permissions for tools. *)
65
-
66
-
type t
67
-
(** The type of permission rules. *)
68
-
69
-
val jsont : t Jsont.t
70
-
(** [jsont] is the Jsont codec for permission rules. Preserves unknown fields
71
-
for forward compatibility. *)
72
-
73
-
val create :
74
-
tool_name:string -> ?rule_content:string -> ?unknown:Unknown.t -> unit -> t
75
-
(** [create ~tool_name ?rule_content ?unknown ()] creates a new rule.
76
-
@param tool_name The name of the tool this rule applies to
77
-
@param rule_content Optional rule specification or pattern
78
-
@param unknown Optional unknown fields to preserve *)
79
-
80
-
val tool_name : t -> string
81
-
(** [tool_name t] returns the tool name. *)
82
-
83
-
val rule_content : t -> string option
84
-
(** [rule_content t] returns the optional rule content. *)
85
-
86
-
val unknown : t -> Unknown.t
87
-
(** [unknown t] returns the unknown fields. *)
88
-
end
89
-
90
-
(** {1 Permission Updates} *)
91
-
92
-
module Update : sig
93
-
(** Updates modify permission settings. *)
94
-
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 *)
110
-
111
-
type t
112
-
(** The type of permission updates. *)
113
-
114
-
val jsont : t Jsont.t
115
-
(** [jsont] is the Jsont codec for permission updates. Wire format uses
116
-
camelCase for destination ("userSettings", "projectSettings",
117
-
"localSettings", "session") and update_type ("addRules", "replaceRules",
118
-
"removeRules", "setMode", "addDirectories", "removeDirectories"). *)
119
-
120
-
val create :
121
-
update_type:update_type ->
122
-
?rules:Rule.t list ->
123
-
?behavior:Behavior.t ->
124
-
?mode:Mode.t ->
125
-
?directories:string list ->
126
-
?destination:destination ->
127
-
?unknown:Unknown.t ->
128
-
unit ->
129
-
t
130
-
(** [create ~update_type ?rules ?behavior ?mode ?directories ?destination
131
-
?unknown ()] creates a new permission update.
132
-
@param update_type The type of update to perform
133
-
@param rules Optional list of rules to add/remove/replace
134
-
@param behavior Optional behavior to set
135
-
@param mode Optional permission mode to set
136
-
@param directories Optional directories to add/remove
137
-
@param destination Optional destination for the update
138
-
@param unknown Optional unknown fields to preserve *)
139
-
140
-
val update_type : t -> update_type
141
-
(** [update_type t] returns the update type. *)
142
-
143
-
val rules : t -> Rule.t list option
144
-
(** [rules t] returns the optional list of rules. *)
145
-
146
-
val behavior : t -> Behavior.t option
147
-
(** [behavior t] returns the optional behavior. *)
148
-
149
-
val mode : t -> Mode.t option
150
-
(** [mode t] returns the optional mode. *)
151
-
152
-
val directories : t -> string list option
153
-
(** [directories t] returns the optional list of directories. *)
154
-
155
-
val destination : t -> destination option
156
-
(** [destination t] returns the optional destination. *)
157
-
158
-
val unknown : t -> Unknown.t
159
-
(** [unknown t] returns the unknown fields. *)
160
-
end
161
-
162
-
(** {1 Permission Context} *)
163
-
164
-
module Context : sig
165
-
(** Context provided to permission callbacks. *)
166
-
167
-
type t
168
-
(** The type of permission context. *)
169
-
170
-
val jsont : t Jsont.t
171
-
(** [jsont] is the Jsont codec for permission context. Preserves unknown
172
-
fields for forward compatibility. *)
173
-
174
-
val create : ?suggestions:Update.t list -> ?unknown:Unknown.t -> unit -> t
175
-
(** [create ?suggestions ?unknown ()] creates a new context.
176
-
@param suggestions Optional list of suggested permission updates
177
-
@param unknown Optional unknown fields to preserve *)
178
-
179
-
val suggestions : t -> Update.t list
180
-
(** [suggestions t] returns the list of suggested updates. *)
181
-
182
-
val unknown : t -> Unknown.t
183
-
(** [unknown t] returns the unknown fields. *)
184
-
end
185
-
186
-
(** {1 Permission Results} *)
187
-
188
-
module Result : sig
189
-
(** Results of permission checks. *)
190
-
191
-
type t =
192
-
| Allow of {
193
-
updated_input : Jsont.json option; (** Modified tool input *)
194
-
updated_permissions : Update.t list option;
195
-
(** Permission updates to apply *)
196
-
unknown : Unknown.t; (** Unknown fields *)
197
-
}
198
-
| Deny of {
199
-
message : string; (** Reason for denial *)
200
-
interrupt : bool; (** Whether to interrupt execution *)
201
-
unknown : Unknown.t; (** Unknown fields *)
202
-
}
203
-
(** The type of permission results. Wire format uses a discriminated
204
-
union with "behavior" field set to "allow" or "deny". *)
205
-
206
-
val jsont : t Jsont.t
207
-
(** [jsont] is the Jsont codec for permission results. Preserves unknown
208
-
fields for forward compatibility. *)
209
-
210
-
val allow :
211
-
?updated_input:Jsont.json ->
212
-
?updated_permissions:Update.t list ->
213
-
?unknown:Unknown.t ->
214
-
unit ->
215
-
t
216
-
(** [allow ?updated_input ?updated_permissions ?unknown ()] creates an allow
217
-
result.
218
-
@param updated_input Optional modified tool input
219
-
@param updated_permissions Optional permission updates to apply
220
-
@param unknown Optional unknown fields to preserve *)
221
-
222
-
val deny : message:string -> interrupt:bool -> ?unknown:Unknown.t -> unit -> t
223
-
(** [deny ~message ~interrupt ?unknown ()] creates a deny result.
224
-
@param message The reason for denying permission
225
-
@param interrupt Whether to interrupt further execution
226
-
@param unknown Optional unknown fields to preserve *)
227
-
end
-17
proto/structured_output.ml
-17
proto/structured_output.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Structured output wire format implementation. *)
7
-
8
-
type t = { json_schema : Jsont.json }
9
-
10
-
let of_json_schema schema = { json_schema = schema }
11
-
let to_json_schema t = t.json_schema
12
-
13
-
(* Codec for serializing structured output format to wire protocol *)
14
-
let jsont : t Jsont.t =
15
-
Jsont.Object.map ~kind:"StructuredOutput" (fun json_schema -> { json_schema })
16
-
|> Jsont.Object.mem "jsonSchema" Jsont.json ~enc:(fun t -> t.json_schema)
17
-
|> Jsont.Object.finish
-67
proto/structured_output.mli
-67
proto/structured_output.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Structured output configuration using JSON Schema.
7
-
8
-
This module provides the wire format types for structured output support,
9
-
allowing specification of expected output formats using JSON schemas. When a
10
-
structured output format is configured, Claude will return its response in
11
-
the specified JSON format, validated against the provided schema.
12
-
13
-
This is the protocol-level module. For the high-level API with logging and
14
-
additional features, see {!Claude.Structured_output}. *)
15
-
16
-
(** {1 Output Format Configuration} *)
17
-
18
-
type t
19
-
(** The type of structured output format configurations.
20
-
21
-
This wraps a JSON Schema that specifies the expected output format. *)
22
-
23
-
val of_json_schema : Jsont.json -> t
24
-
(** [of_json_schema schema] creates an output format from a JSON Schema.
25
-
26
-
The schema should be a valid JSON Schema Draft 7 as a {!type:Jsont.json}
27
-
value.
28
-
29
-
Example:
30
-
{[
31
-
let meta = Jsont.Meta.none in
32
-
let schema =
33
-
Jsont.Object
34
-
( [
35
-
(("type", meta), Jsont.String ("object", meta));
36
-
( ("properties", meta),
37
-
Jsont.Object
38
-
( [
39
-
( ("name", meta),
40
-
Jsont.Object
41
-
([ (("type", meta), Jsont.String ("string", meta)) ], meta)
42
-
);
43
-
( ("age", meta),
44
-
Jsont.Object
45
-
([ (("type", meta), Jsont.String ("integer", meta)) ], meta)
46
-
);
47
-
],
48
-
meta ) );
49
-
( ("required", meta),
50
-
Jsont.Array
51
-
([ Jsont.String ("name", meta); Jsont.String ("age", meta) ], meta)
52
-
);
53
-
],
54
-
meta )
55
-
in
56
-
57
-
let format = Structured_output.of_json_schema schema
58
-
]} *)
59
-
60
-
val to_json_schema : t -> Jsont.json
61
-
(** [to_json_schema t] extracts the JSON Schema from the output format. *)
62
-
63
-
val jsont : t Jsont.t
64
-
(** Codec for structured output format.
65
-
66
-
Encodes/decodes the structured output configuration to/from the wire format
67
-
JSON representation used by the Claude CLI protocol. *)
-64
proto/unknown.ml
-64
proto/unknown.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Unknown fields for preserving extra JSON object members during
7
-
round-tripping.
8
-
9
-
This module provides an opaque type for storing unknown JSON fields as an
10
-
association list. This is useful for preserving fields that are not part of
11
-
the defined schema but should be maintained when reading and writing JSON.
12
-
*)
13
-
14
-
type t = (string * Jsont.json) list
15
-
16
-
let empty = []
17
-
let is_empty = function [] -> true | _ -> false
18
-
let of_assoc x = x
19
-
let to_assoc x = x
20
-
21
-
let jsont =
22
-
let open Jsont in
23
-
let dec obj =
24
-
match obj with
25
-
| Object (fields, _) ->
26
-
(* Convert from Jsont.mem list (name * json) to (string * json) list *)
27
-
List.map (fun ((name, _meta), json) -> (name, json)) fields
28
-
| _ -> invalid_arg "Expected object"
29
-
in
30
-
let enc fields =
31
-
(* Convert from (string * json) list to Jsont.mem list *)
32
-
let mems =
33
-
List.map (fun (name, json) -> ((name, Meta.none), json)) fields
34
-
in
35
-
Object (mems, Meta.none)
36
-
in
37
-
map ~dec ~enc json
38
-
39
-
(** Mems codec for use with Jsont.Object.keep_unknown.
40
-
41
-
This provides a custom mems codec that converts between our (string *
42
-
Jsont.json) list representation and the Jsont.mem list representation used
43
-
by keep_unknown. *)
44
-
let mems : (t, Jsont.json, Jsont.mem list) Jsont.Object.Mems.map =
45
-
let open Jsont in
46
-
(* The decoder builds up a mem list (the third type parameter) and
47
-
dec_finish converts it to our type t *)
48
-
let dec_empty () = [] in
49
-
let dec_add meta name json acc = ((name, meta), json) :: acc in
50
-
let dec_finish _meta mems =
51
-
(* Convert from mem list to (string * json) list *)
52
-
List.rev_map (fun ((name, _meta), json) -> (name, json)) mems
53
-
in
54
-
let enc =
55
-
{
56
-
Object.Mems.enc =
57
-
(fun k fields acc ->
58
-
List.fold_left
59
-
(fun acc (name, json) -> k Meta.none name json acc)
60
-
acc fields);
61
-
}
62
-
in
63
-
Object.Mems.map ~kind:"Unknown" ~dec_empty ~dec_add ~dec_finish ~enc
64
-
Jsont.json
-34
proto/unknown.mli
-34
proto/unknown.mli
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Unknown fields for preserving extra JSON object members during
7
-
round-tripping.
8
-
9
-
This module provides an opaque type for storing unknown JSON fields as an
10
-
association list. This is useful for preserving fields that are not part of
11
-
the defined schema but should be maintained when reading and writing JSON.
12
-
*)
13
-
14
-
type t
15
-
(** The opaque type of unknown fields, stored as an association list of field
16
-
names to JSON values. *)
17
-
18
-
val empty : t
19
-
(** [empty] is an empty set of unknown fields. *)
20
-
21
-
val is_empty : t -> bool
22
-
(** [is_empty t] returns [true] if there are no unknown fields stored in [t]. *)
23
-
24
-
val of_assoc : (string * Jsont.json) list -> t
25
-
(** [of_assoc assoc] creates unknown fields from an association list. *)
26
-
27
-
val to_assoc : t -> (string * Jsont.json) list
28
-
(** [to_assoc t] returns the association list of unknown fields. *)
29
-
30
-
val jsont : t Jsont.t
31
-
(** [jsont] is a codec for encoding and decoding unknown fields to/from JSON. *)
32
-
33
-
val mems : (t, Jsont.json, Jsont.mem list) Jsont.Object.Mems.map
34
-
(** [mems] is a mems codec for use with [Jsont.Object.keep_unknown]. *)
-35
test/README.md
-35
test/README.md
···
1
-
# Claude IO Test Suite
2
-
3
-
This directory contains test programs for the Claude IO OCaml library.
4
-
5
-
## Available Tests
6
-
7
-
### camel_jokes
8
-
A fun demonstration that runs three concurrent Claude instances to generate camel jokes.
9
-
Tests concurrent client handling and basic message processing.
10
-
11
-
### permission_demo
12
-
An interactive demonstration of Claude's permission system.
13
-
Shows how to implement custom permission callbacks and grant/deny access to tools dynamically.
14
-
15
-
## Running Tests
16
-
17
-
```bash
18
-
# Run the camel joke competition
19
-
dune exec camel_jokes
20
-
21
-
# Run the permission demo (interactive)
22
-
dune exec permission_demo
23
-
24
-
# With verbose output to see message flow
25
-
dune exec permission_demo -- -v
26
-
```
27
-
28
-
## Features Tested
29
-
30
-
- Concurrent Claude client instances
31
-
- Message handling and processing
32
-
- Permission callbacks
33
-
- Tool access control
34
-
- Typed message API
35
-
- Pretty printing of messages
-112
test/TEST.md
-112
test/TEST.md
···
1
-
# Claude Library Architecture Summary
2
-
3
-
This document summarizes the architecture of the OCaml Eio Claude library located in `../lib`.
4
-
5
-
## Overview
6
-
7
-
The Claude library is a high-quality OCaml Eio wrapper around the Claude Code CLI that provides structured JSON streaming communication with Claude. It follows a clean layered architecture with strong typing and comprehensive error handling.
8
-
9
-
## Core Architecture
10
-
11
-
The library is organized into several focused modules that work together to provide a complete Claude integration:
12
-
13
-
### 1. Transport Layer (`Transport`)
14
-
- **Purpose**: Low-level CLI process management and communication
15
-
- **Key Functions**:
16
-
- Spawns and manages the `claude` CLI process using Eio's process manager
17
-
- Handles bidirectional JSON streaming via stdin/stdout
18
-
- Provides `send`/`receive_line` primitives with proper resource cleanup
19
-
- **Integration**: Forms the foundation for all Claude communication
20
-
21
-
### 2. Message Protocol Layer
22
-
23
-
#### Content Blocks (`Content_block`)
24
-
- **Purpose**: Defines the building blocks of Claude messages
25
-
- **Types**: Text, Tool_use, Tool_result, Thinking blocks
26
-
- **Key Features**: Each block type has specialized accessors and JSON serialization
27
-
- **Integration**: Used by messages to represent diverse content types
28
-
29
-
#### Messages (`Message`)
30
-
- **Purpose**: Structured message types for Claude communication
31
-
- **Types**: User, Assistant, System, Result messages
32
-
- **Key Features**:
33
-
- User messages support both simple strings and complex content blocks
34
-
- Assistant messages include model info and mixed content
35
-
- System messages handle session control
36
-
- Result messages provide conversation metadata and usage stats
37
-
- **Integration**: Primary data structures exchanged between client and Claude
38
-
39
-
#### Control Messages (`Control`)
40
-
- **Purpose**: Session management and control flow
41
-
- **Key Features**: Request IDs, subtypes, and arbitrary JSON data payload
42
-
- **Integration**: Used for session initialization, cancellation, and other operational commands
43
-
44
-
### 3. Permission System (`Permissions`)
45
-
- **Purpose**: Fine-grained control over Claude's tool usage
46
-
- **Components**:
47
-
- **Modes**: Default, Accept_edits, Plan, Bypass_permissions
48
-
- **Rules**: Tool-specific permission specifications
49
-
- **Callbacks**: Custom permission logic with context and suggestions
50
-
- **Results**: Allow/Deny decisions with optional modifications
51
-
- **Integration**: Consulted by client before allowing tool invocations
52
-
53
-
### 4. Configuration (`Options`)
54
-
- **Purpose**: Session configuration and behavior control
55
-
- **Features**:
56
-
- Tool allow/disallow lists
57
-
- System prompt customization (replace or append)
58
-
- Model selection and thinking token limits
59
-
- Working directory and environment variables
60
-
- **Integration**: Passed to transport layer and used throughout the session
61
-
- **Pattern**: Builder pattern with `with_*` functions for immutable updates
62
-
63
-
### 5. Client Interface (`Client`)
64
-
- **Purpose**: High-level API for Claude interactions
65
-
- **Key Functions**:
66
-
- Session creation and management
67
-
- Message sending (`query`, `send_message`, `send_user_message`)
68
-
- Response streaming (`receive`, `receive_all`)
69
-
- Permission discovery and callback management
70
-
- **Integration**: Orchestrates all other modules to provide the main user API
71
-
72
-
### 6. Main Module (`Claude`)
73
-
- **Purpose**: Public API facade with comprehensive documentation
74
-
- **Features**:
75
-
- Re-exports all sub-modules
76
-
- Extensive usage examples and architectural documentation
77
-
- Logging configuration guidance
78
-
- **Integration**: Single entry point for library users
79
-
80
-
## Data Flow
81
-
82
-
1. **Configuration**: Options are created with desired settings
83
-
2. **Transport**: Client creates transport layer with CLI process
84
-
3. **Message Exchange**:
85
-
- User messages are sent via JSON streaming
86
-
- Claude responses are received as streaming JSON
87
-
- Messages are parsed into strongly-typed structures
88
-
4. **Permission Checking**: Tool usage is filtered through permission system
89
-
5. **Content Processing**: Response content blocks are extracted and processed
90
-
6. **Session Management**: Control messages handle session lifecycle
91
-
92
-
## Key Design Principles
93
-
94
-
- **Eio Integration**: Native use of Eio's concurrency primitives (Switch, Process.mgr)
95
-
- **Type Safety**: Comprehensive typing with specific error exceptions
96
-
- **Streaming**: Efficient processing via `Message.t Seq.t` sequences
97
-
- **Modularity**: Clear separation of concerns with minimal inter-dependencies
98
-
- **Documentation**: Extensive interface documentation with usage examples
99
-
- **Error Handling**: Specific exception types for different failure modes
100
-
- **Logging**: Structured logging with per-module sources using the Logs library
101
-
102
-
## Usage Patterns
103
-
104
-
The library supports both simple text queries and complex multi-turn conversations:
105
-
106
-
- **Simple Queries**: `Client.query` with text input
107
-
- **Tool Control**: Permission callbacks and allow/disallow lists
108
-
- **Streaming**: Process responses as they arrive via sequences
109
-
- **Session Management**: Full control over Claude's execution environment
110
-
- **Custom Prompts**: System prompt replacement and augmentation
111
-
112
-
The architecture enables fine-grained control over Claude's capabilities while maintaining ease of use for common scenarios.
-162
test/advanced_config_demo.ml
-162
test/advanced_config_demo.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(* Advanced Configuration Demo
7
-
8
-
This example demonstrates the advanced configuration options available
9
-
in the OCaml Claude SDK, including:
10
-
- Budget limits for cost control
11
-
- Fallback models for reliability
12
-
- Settings isolation for CI/CD environments
13
-
- Custom buffer sizes for large outputs
14
-
*)
15
-
16
-
open Eio.Std
17
-
open Claude
18
-
19
-
let log_setup () =
20
-
Logs.set_reporter (Logs_fmt.reporter ());
21
-
Logs.set_level (Some Logs.Info)
22
-
23
-
(* Example 1: CI/CD Configuration
24
-
25
-
In CI/CD environments, you want isolated, reproducible behavior
26
-
without any user/project/local settings interfering.
27
-
*)
28
-
let ci_cd_config () =
29
-
Options.default |> Options.with_no_settings (* Disable all settings loading *)
30
-
|> Options.with_max_budget_usd 0.50 (* 50 cent limit per run *)
31
-
|> Options.with_fallback_model (Claude.Proto.Model.of_string "claude-haiku-4")
32
-
(* Fast fallback *)
33
-
|> Options.with_model (Claude.Proto.Model.of_string "claude-sonnet-4-5")
34
-
|> Options.with_permission_mode Permissions.Mode.Bypass_permissions
35
-
36
-
(* Example 2: Production Configuration with Fallback
37
-
38
-
Production usage with cost controls and automatic fallback
39
-
to ensure availability.
40
-
*)
41
-
let production_config () =
42
-
Options.default
43
-
|> Options.with_model (Claude.Proto.Model.of_string "claude-sonnet-4-5")
44
-
|> Options.with_fallback_model
45
-
(Claude.Proto.Model.of_string "claude-sonnet-3-5")
46
-
|> Options.with_max_budget_usd 10.0 (* $10 limit *)
47
-
|> Options.with_max_buffer_size 5_000_000 (* 5MB buffer for large outputs *)
48
-
49
-
(* Example 3: Development Configuration
50
-
51
-
Development with user settings enabled but with cost controls.
52
-
*)
53
-
let dev_config () =
54
-
Options.default
55
-
(* Note: Settings are loaded by default from user/project/local files *)
56
-
|> Options.with_max_budget_usd 1.0 (* $1 limit for dev testing *)
57
-
|> Options.with_fallback_model (Claude.Proto.Model.of_string "claude-haiku-4")
58
-
59
-
(* Example 4: Isolated Test Configuration
60
-
61
-
For automated testing with no external settings and strict limits.
62
-
*)
63
-
let test_config () =
64
-
Options.default |> Options.with_no_settings
65
-
|> Options.with_max_budget_usd 0.10 (* 10 cent limit per test *)
66
-
|> Options.with_model (Claude.Proto.Model.of_string "claude-haiku-4")
67
-
(* Fast, cheap model *)
68
-
|> Options.with_permission_mode Permissions.Mode.Bypass_permissions
69
-
|> Options.with_max_buffer_size 1_000_000 (* 1MB buffer *)
70
-
71
-
(* Example 5: Custom Buffer Size Demo
72
-
73
-
For applications that need to handle very large outputs.
74
-
*)
75
-
let _large_output_config () =
76
-
Options.default
77
-
|> Options.with_max_buffer_size 10_000_000 (* 10MB buffer *)
78
-
|> Options.with_model (Claude.Proto.Model.of_string "claude-sonnet-4-5")
79
-
80
-
(* Helper to run a query with a specific configuration *)
81
-
let run_query ~sw process_mgr clock config prompt =
82
-
print_endline "\n=== Configuration ===";
83
-
(match Options.max_budget_usd config with
84
-
| Some budget -> Printf.printf "Budget limit: $%.2f\n" budget
85
-
| None -> print_endline "Budget limit: None");
86
-
(match Options.fallback_model config with
87
-
| Some model ->
88
-
Printf.printf "Fallback model: %s\n" (Claude.Proto.Model.to_string model)
89
-
| None -> print_endline "Fallback model: None");
90
-
(* Settings configuration display removed - API doesn't expose setting_sources *)
91
-
print_endline "Settings: Default (user/project/local files)";
92
-
(match Options.max_buffer_size config with
93
-
| Some size -> Printf.printf "Buffer size: %d bytes\n" size
94
-
| None -> print_endline "Buffer size: Default (1MB)");
95
-
96
-
print_endline "\n=== Running Query ===";
97
-
let client = Client.create ~options:config ~sw ~process_mgr ~clock () in
98
-
Client.query client prompt;
99
-
let responses = Client.receive client in
100
-
101
-
Seq.iter
102
-
(function
103
-
| Response.Text text ->
104
-
Printf.printf "Response: %s\n" (Response.Text.content text)
105
-
| Response.Complete result ->
106
-
Printf.printf "\n=== Session Complete ===\n";
107
-
Printf.printf "Duration: %dms\n"
108
-
(Response.Complete.duration_ms result);
109
-
(match Response.Complete.total_cost_usd result with
110
-
| Some cost -> Printf.printf "Cost: $%.4f\n" cost
111
-
| None -> ());
112
-
Printf.printf "Turns: %d\n" (Response.Complete.num_turns result)
113
-
| _ -> ())
114
-
responses
115
-
116
-
let main () =
117
-
log_setup ();
118
-
119
-
Eio_main.run @@ fun env ->
120
-
Switch.run @@ fun sw ->
121
-
let process_mgr = Eio.Stdenv.process_mgr env in
122
-
let clock = Eio.Stdenv.clock env in
123
-
124
-
print_endline "==============================================";
125
-
print_endline "Claude SDK - Advanced Configuration Examples";
126
-
print_endline "==============================================";
127
-
128
-
(* Example: CI/CD isolated environment *)
129
-
print_endline "\n\n### Example 1: CI/CD Configuration ###";
130
-
print_endline "Purpose: Isolated, reproducible environment for CI/CD";
131
-
let config = ci_cd_config () in
132
-
run_query ~sw process_mgr clock config "What is 2+2? Answer in one sentence.";
133
-
134
-
(* Example: Production with fallback *)
135
-
print_endline "\n\n### Example 2: Production Configuration ###";
136
-
print_endline "Purpose: Production with cost controls and fallback";
137
-
let config = production_config () in
138
-
run_query ~sw process_mgr clock config "Explain OCaml in one sentence.";
139
-
140
-
(* Example: Development with settings *)
141
-
print_endline "\n\n### Example 3: Development Configuration ###";
142
-
print_endline "Purpose: Development with user/project settings";
143
-
let config = dev_config () in
144
-
run_query ~sw process_mgr clock config
145
-
"What is functional programming? One sentence.";
146
-
147
-
(* Example: Test configuration *)
148
-
print_endline "\n\n### Example 4: Test Configuration ###";
149
-
print_endline "Purpose: Automated testing with strict limits";
150
-
let config = test_config () in
151
-
run_query ~sw process_mgr clock config "Say 'test passed' in one word.";
152
-
153
-
print_endline "\n\n==============================================";
154
-
print_endline "All examples completed successfully!";
155
-
print_endline "=============================================="
156
-
157
-
let () =
158
-
try main ()
159
-
with e ->
160
-
Printf.eprintf "Error: %s\n" (Printexc.to_string e);
161
-
Printexc.print_backtrace stderr;
162
-
exit 1
-139
test/camel_jokes.ml
-139
test/camel_jokes.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
open Eio.Std
7
-
8
-
let src = Logs.Src.create "camel_jokes" ~doc:"Camel joke competition"
9
-
10
-
module Log = (val Logs.src_log src : Logs.LOG)
11
-
12
-
let process_claude_response client name =
13
-
Log.info (fun m -> m "=== %s's Response ===" name);
14
-
let responses = Claude.Client.receive_all client in
15
-
List.iter
16
-
(fun resp ->
17
-
match resp with
18
-
| Claude.Response.Text t ->
19
-
let text = Claude.Response.Text.content t in
20
-
Log.app (fun m -> m "%s: %s" name text)
21
-
| Claude.Response.Tool_use t ->
22
-
Log.debug (fun m ->
23
-
m "%s using tool: %s" name (Claude.Response.Tool_use.name t))
24
-
| Claude.Response.Thinking t ->
25
-
Log.debug (fun m ->
26
-
m "%s thinking: %s" name (Claude.Response.Thinking.content t))
27
-
| Claude.Response.Complete c ->
28
-
(if Claude.Response.Complete.total_cost_usd c <> None then
29
-
let cost =
30
-
Option.get (Claude.Response.Complete.total_cost_usd c)
31
-
in
32
-
Log.info (fun m -> m "%s's joke cost: $%.6f" name cost));
33
-
Log.debug (fun m ->
34
-
m "%s session: %s, duration: %dms" name
35
-
(Claude.Response.Complete.session_id c)
36
-
(Claude.Response.Complete.duration_ms c))
37
-
| Claude.Response.Error e ->
38
-
Log.err (fun m ->
39
-
m "Error from %s: %s" name (Claude.Response.Error.message e))
40
-
| Claude.Response.Init _ ->
41
-
(* Init messages are already logged by the library *)
42
-
()
43
-
| Claude.Response.Tool_result _ ->
44
-
(* Tool results are user messages, skip *)
45
-
())
46
-
responses
47
-
48
-
let run_claude ~sw ~env name prompt =
49
-
Log.info (fun m -> m "🐪 Starting %s..." name);
50
-
let options =
51
-
Claude.Options.default
52
-
|> Claude.Options.with_model (Claude.Model.of_string "sonnet")
53
-
|> Claude.Options.with_allowed_tools []
54
-
in
55
-
56
-
let client =
57
-
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr
58
-
~clock:env#clock ()
59
-
in
60
-
61
-
Claude.Client.query client prompt;
62
-
process_claude_response client name
63
-
64
-
let main ~env =
65
-
Switch.run @@ fun sw ->
66
-
Log.app (fun m -> m "🐪 Starting the Great Camel Joke Competition! 🐪");
67
-
Log.app (fun m -> m "================================================\n");
68
-
69
-
let prompts =
70
-
[
71
-
( "Claude 1",
72
-
"Tell me a short, funny joke about camels! Make it original and clever."
73
-
);
74
-
( "Claude 2",
75
-
"Give me your best camel joke - something witty and unexpected!" );
76
-
("Claude 3", "Share a hilarious camel joke that will make everyone laugh!");
77
-
]
78
-
in
79
-
80
-
(* Run all three Claudes concurrently *)
81
-
Fiber.all
82
-
(List.map
83
-
(fun (name, prompt) -> fun () -> run_claude ~sw ~env name prompt)
84
-
prompts);
85
-
86
-
Log.app (fun m -> m "\n================================================");
87
-
Log.app (fun m -> m "🎉 The Camel Joke Competition is complete! 🎉")
88
-
89
-
(* Command-line interface *)
90
-
open Cmdliner
91
-
92
-
let main_term env =
93
-
let setup_log style_renderer level =
94
-
Fmt_tty.setup_std_outputs ?style_renderer ();
95
-
Logs.set_level level;
96
-
Logs.set_reporter (Logs_fmt.reporter ());
97
-
(* Set default to App level if not specified *)
98
-
if level = None then Logs.set_level (Some Logs.App);
99
-
(* Enable debug for Client module if in debug mode *)
100
-
if level = Some Logs.Debug then
101
-
Logs.Src.set_level Claude.Client.src (Some Logs.Debug)
102
-
in
103
-
let run style level =
104
-
setup_log style level;
105
-
main ~env
106
-
in
107
-
Term.(const run $ Fmt_cli.style_renderer () $ Logs_cli.level ())
108
-
109
-
let cmd env =
110
-
let doc = "Run the Great Camel Joke Competition using Claude" in
111
-
let man =
112
-
[
113
-
`S Manpage.s_description;
114
-
`P
115
-
"This program runs three concurrent Claude instances to generate camel \
116
-
jokes.";
117
-
`P "Use $(b,-v) or $(b,--verbosity=info) to see RPC message traffic.";
118
-
`P
119
-
"Use $(b,-vv) or $(b,--verbosity=debug) to see all internal operations.";
120
-
`S Manpage.s_examples;
121
-
`P "Run with normal output:";
122
-
`Pre " $(mname)";
123
-
`P "Run with info-level logging (RPC traffic):";
124
-
`Pre " $(mname) -v";
125
-
`Pre " $(mname) --verbosity=info";
126
-
`P "Run with debug logging (all operations):";
127
-
`Pre " $(mname) -vv";
128
-
`Pre " $(mname) --verbosity=debug";
129
-
`P "Enable debug for specific modules:";
130
-
`Pre " LOGS='claude.transport=debug' $(mname)";
131
-
`Pre " LOGS='claude.message=info,camel_jokes=debug' $(mname)";
132
-
`S Manpage.s_bugs;
133
-
`P "Report bugs at https://github.com/your-repo/issues";
134
-
]
135
-
in
136
-
let info = Cmd.info "camel_jokes" ~version:"1.0" ~doc ~man in
137
-
Cmd.v info (main_term env)
138
-
139
-
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
-111
test/discovery_demo.ml
-111
test/discovery_demo.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
open Eio.Std
7
-
8
-
let src =
9
-
Logs.Src.create "discovery_demo" ~doc:"Permission discovery demonstration"
10
-
11
-
module Log = (val Logs.src_log src : Logs.LOG)
12
-
13
-
let process_response client =
14
-
let responses = Claude.Client.receive_all client in
15
-
List.iter
16
-
(fun resp ->
17
-
match resp with
18
-
| Claude.Response.Text text ->
19
-
let content = Claude.Response.Text.content text in
20
-
Log.app (fun m ->
21
-
m "Claude: %s"
22
-
(if String.length content > 100 then
23
-
String.sub content 0 100 ^ "..."
24
-
else content))
25
-
| Claude.Response.Tool_use t ->
26
-
Log.info (fun m -> m "Tool use: %s" (Claude.Response.Tool_use.name t))
27
-
| Claude.Response.Error err ->
28
-
Log.err (fun m -> m "Error: %s" (Claude.Response.Error.message err))
29
-
| Claude.Response.Complete result -> (
30
-
match Claude.Response.Complete.total_cost_usd result with
31
-
| Some cost -> Log.info (fun m -> m "Cost: $%.6f" cost)
32
-
| None -> ())
33
-
| _ -> ())
34
-
responses
35
-
36
-
let run_discovery ~sw ~env =
37
-
Log.app (fun m -> m "🔍 Permission Discovery Demo");
38
-
Log.app (fun m -> m "=============================");
39
-
Log.app (fun m -> m "This will discover what permissions Claude needs.\n");
40
-
41
-
(* Create client with discovery mode *)
42
-
let options =
43
-
Claude.Options.default
44
-
|> Claude.Options.with_model (Claude.Proto.Model.of_string "sonnet")
45
-
in
46
-
let client =
47
-
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr
48
-
~clock:env#clock ()
49
-
in
50
-
Claude.Client.enable_permission_discovery client;
51
-
52
-
(* Send a prompt that will need permissions *)
53
-
Log.app (fun m -> m "Asking Claude to read a secret file...");
54
-
Claude.Client.query client
55
-
"Please read the file test/secret_data.txt and tell me what the secret \
56
-
code is.";
57
-
process_response client;
58
-
59
-
(* Check what permissions were requested *)
60
-
let permissions = Claude.Client.discovered_permissions client in
61
-
if permissions = [] then
62
-
Log.app (fun m ->
63
-
m
64
-
"\n\
65
-
📋 No permissions were requested (Claude may have used its \
66
-
knowledge).")
67
-
else begin
68
-
Log.app (fun m -> m "\n📋 Permissions that were requested:");
69
-
List.iter
70
-
(fun rule ->
71
-
Log.app (fun m ->
72
-
m " - Tool: %s%s"
73
-
(Claude.Permissions.Rule.tool_name rule)
74
-
(match Claude.Permissions.Rule.rule_content rule with
75
-
| Some content -> Printf.sprintf " (rule: %s)" content
76
-
| None -> "")))
77
-
permissions
78
-
end
79
-
80
-
let main ~env = Switch.run @@ fun sw -> run_discovery ~sw ~env
81
-
82
-
(* Command-line interface *)
83
-
open Cmdliner
84
-
85
-
let main_term env =
86
-
let setup_log style_renderer level =
87
-
Fmt_tty.setup_std_outputs ?style_renderer ();
88
-
Logs.set_level level;
89
-
Logs.set_reporter (Logs_fmt.reporter ());
90
-
if level = None then Logs.set_level (Some Logs.App)
91
-
in
92
-
let run style level =
93
-
setup_log style level;
94
-
main ~env
95
-
in
96
-
Term.(const run $ Fmt_cli.style_renderer () $ Logs_cli.level ())
97
-
98
-
let cmd env =
99
-
let doc = "Discover what permissions Claude needs" in
100
-
let man =
101
-
[
102
-
`S Manpage.s_description;
103
-
`P
104
-
"This program runs Claude in discovery mode to see what permissions it \
105
-
requests.";
106
-
]
107
-
in
108
-
let info = Cmd.info "discovery_demo" ~version:"1.0" ~doc ~man in
109
-
Cmd.v info (main_term env)
110
-
111
-
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
-89
test/dynamic_control_demo.ml
-89
test/dynamic_control_demo.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
open Claude
7
-
open Eio.Std
8
-
9
-
let () = Logs.set_reporter (Logs_fmt.reporter ())
10
-
let () = Logs.set_level (Some Logs.Info)
11
-
12
-
let run env =
13
-
Switch.run @@ fun sw ->
14
-
let process_mgr = Eio.Stdenv.process_mgr env in
15
-
let clock = Eio.Stdenv.clock env in
16
-
17
-
(* Create client with default options *)
18
-
let options = Options.default in
19
-
let client = Client.create ~options ~sw ~process_mgr ~clock () in
20
-
21
-
traceln "=== Dynamic Control Demo ===\n";
22
-
23
-
(* First query with default model *)
24
-
traceln "1. Initial query with default model";
25
-
Client.query client "What model are you?";
26
-
27
-
(* Consume initial responses *)
28
-
let responses = Client.receive_all client in
29
-
List.iter
30
-
(function
31
-
| Response.Text text ->
32
-
traceln "Assistant: %s" (Response.Text.content text)
33
-
| _ -> ())
34
-
responses;
35
-
36
-
traceln "\n2. Getting server info...";
37
-
(try
38
-
let info = Client.get_server_info client in
39
-
traceln "Server version: %s" (Claude.Server_info.version info);
40
-
traceln "Capabilities: [%s]"
41
-
(String.concat ", " (Claude.Server_info.capabilities info));
42
-
traceln "Commands: [%s]"
43
-
(String.concat ", " (Claude.Server_info.commands info));
44
-
traceln "Output styles: [%s]"
45
-
(String.concat ", " (Claude.Server_info.output_styles info))
46
-
with
47
-
| Failure msg -> traceln "Failed to get server info: %s" msg
48
-
| exn -> traceln "Error getting server info: %s" (Printexc.to_string exn));
49
-
50
-
traceln "\n3. Switching to a different model (if available)...";
51
-
(try
52
-
Client.set_model client (Proto.Model.of_string "claude-sonnet-4");
53
-
traceln "Model switched successfully";
54
-
55
-
(* Query with new model *)
56
-
Client.query client "Confirm your model again please.";
57
-
let responses = Client.receive_all client in
58
-
List.iter
59
-
(function
60
-
| Response.Text text ->
61
-
traceln "Assistant (new model): %s" (Response.Text.content text)
62
-
| _ -> ())
63
-
responses
64
-
with
65
-
| Failure msg -> traceln "Failed to switch model: %s" msg
66
-
| exn -> traceln "Error switching model: %s" (Printexc.to_string exn));
67
-
68
-
traceln "\n4. Changing permission mode...";
69
-
(try
70
-
Client.set_permission_mode client Permissions.Mode.Accept_edits;
71
-
traceln "Permission mode changed to Accept_edits"
72
-
with
73
-
| Failure msg -> traceln "Failed to change permission mode: %s" msg
74
-
| exn -> traceln "Error changing permission mode: %s" (Printexc.to_string exn));
75
-
76
-
traceln "\n=== Demo Complete ===";
77
-
()
78
-
79
-
let () =
80
-
Eio_main.run @@ fun env ->
81
-
try run env with
82
-
| Transport.CLI_not_found msg ->
83
-
traceln "Error: %s" msg;
84
-
traceln "Make sure the 'claude' CLI is installed and authenticated.";
85
-
exit 1
86
-
| exn ->
87
-
traceln "Unexpected error: %s" (Printexc.to_string exn);
88
-
Printexc.print_backtrace stderr;
89
-
exit 1
-123
test/hooks_example.ml
-123
test/hooks_example.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
open Eio.Std
7
-
8
-
let src = Logs.Src.create "hooks_example" ~doc:"Hooks example"
9
-
10
-
module Log = (val Logs.src_log src : Logs.LOG)
11
-
12
-
(* Example 1: Block dangerous bash commands *)
13
-
let block_dangerous_bash input =
14
-
if input.Claude.Hooks.PreToolUse.tool_name = "Bash" then
15
-
match
16
-
Claude.Tool_input.get_string input.Claude.Hooks.PreToolUse.tool_input
17
-
"command"
18
-
with
19
-
| Some command ->
20
-
if String.length command >= 6 && String.sub command 0 6 = "rm -rf" then begin
21
-
Log.app (fun m -> m "🚫 Blocked dangerous command: %s" command);
22
-
Claude.Hooks.PreToolUse.deny
23
-
~reason:"Command contains dangerous 'rm -rf' pattern" ()
24
-
end
25
-
else Claude.Hooks.PreToolUse.continue ()
26
-
| _ -> Claude.Hooks.PreToolUse.continue ()
27
-
else Claude.Hooks.PreToolUse.continue ()
28
-
29
-
(* Example 2: Log all tool usage *)
30
-
let log_tool_usage input =
31
-
Log.app (fun m ->
32
-
m "📝 Tool %s called" input.Claude.Hooks.PreToolUse.tool_name);
33
-
Claude.Hooks.PreToolUse.continue ()
34
-
35
-
let run_example ~sw ~env =
36
-
Log.app (fun m -> m "🔧 Hooks System Example");
37
-
Log.app (fun m -> m "====================\n");
38
-
39
-
(* Configure hooks *)
40
-
let hooks =
41
-
Claude.Hooks.empty
42
-
|> Claude.Hooks.on_pre_tool_use log_tool_usage
43
-
|> Claude.Hooks.on_pre_tool_use ~pattern:"Bash" block_dangerous_bash
44
-
in
45
-
46
-
let options =
47
-
Claude.Options.default
48
-
|> Claude.Options.with_model (Claude.Model.of_string "sonnet")
49
-
|> Claude.Options.with_hooks hooks
50
-
in
51
-
52
-
let client =
53
-
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr
54
-
~clock:env#clock ()
55
-
in
56
-
57
-
(* Test 1: Safe command (should work) *)
58
-
Log.app (fun m -> m "Test 1: Safe bash command");
59
-
Claude.Client.query client "Run the bash command: echo 'Hello from hooks!'";
60
-
61
-
let messages = Claude.Client.receive_all client in
62
-
List.iter
63
-
(fun resp ->
64
-
match resp with
65
-
| Claude.Response.Text text ->
66
-
let content = Claude.Response.Text.content text in
67
-
if String.length content > 0 then
68
-
Log.app (fun m -> m "Claude: %s" content)
69
-
| Claude.Response.Complete _ -> Log.app (fun m -> m "✅ Test 1 complete\n")
70
-
| Claude.Response.Error err ->
71
-
Log.err (fun m -> m "❌ Error: %s" (Claude.Response.Error.message err))
72
-
| _ -> ())
73
-
messages;
74
-
75
-
(* Test 2: Dangerous command (should be blocked) *)
76
-
Log.app (fun m -> m "Test 2: Dangerous bash command (should be blocked)");
77
-
Claude.Client.query client "Run the bash command: rm -rf /tmp/test";
78
-
79
-
let messages = Claude.Client.receive_all client in
80
-
List.iter
81
-
(fun resp ->
82
-
match resp with
83
-
| Claude.Response.Text text ->
84
-
let content = Claude.Response.Text.content text in
85
-
if String.length content > 0 then
86
-
Log.app (fun m -> m "Claude: %s" content)
87
-
| Claude.Response.Complete _ -> Log.app (fun m -> m "✅ Test 2 complete")
88
-
| Claude.Response.Error err ->
89
-
Log.err (fun m -> m "❌ Error: %s" (Claude.Response.Error.message err))
90
-
| _ -> ())
91
-
messages;
92
-
93
-
Log.app (fun m -> m "\n====================");
94
-
Log.app (fun m -> m "✨ Example complete!")
95
-
96
-
let main ~env = Switch.run @@ fun sw -> run_example ~sw ~env
97
-
98
-
(* Command-line interface *)
99
-
open Cmdliner
100
-
101
-
let main_term env =
102
-
let setup_log style_renderer level =
103
-
Fmt_tty.setup_std_outputs ?style_renderer ();
104
-
Logs.set_level level;
105
-
Logs.set_reporter (Logs_fmt.reporter ());
106
-
if level = None then Logs.set_level (Some Logs.App);
107
-
match level with
108
-
| Some Logs.Info | Some Logs.Debug ->
109
-
Logs.Src.set_level Claude.Client.src (Some Logs.Info)
110
-
| _ -> ()
111
-
in
112
-
let run style level =
113
-
setup_log style level;
114
-
main ~env
115
-
in
116
-
Term.(const run $ Fmt_cli.style_renderer () $ Logs_cli.level ())
117
-
118
-
let cmd env =
119
-
let doc = "Demonstrate Claude's hooks system" in
120
-
let info = Cmd.info "hooks_example" ~version:"1.0" ~doc in
121
-
Cmd.v info (main_term env)
122
-
123
-
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
-243
test/permission_demo.ml
-243
test/permission_demo.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
open Eio.Std
7
-
8
-
let src =
9
-
Logs.Src.create "permission_demo" ~doc:"Permission callback demonstration"
10
-
11
-
module Log = (val Logs.src_log src : Logs.LOG)
12
-
13
-
(* Mutable state to track what permissions have been granted *)
14
-
module Granted = struct
15
-
module StringSet = Set.Make (String)
16
-
17
-
let tools = ref StringSet.empty
18
-
19
-
let grant tool_name =
20
-
tools := StringSet.add tool_name !tools;
21
-
Log.app (fun m -> m "✅ Permission granted for: %s" tool_name)
22
-
23
-
let deny tool_name =
24
-
Log.app (fun m -> m "❌ Permission denied for: %s" tool_name)
25
-
26
-
let is_granted tool_name = StringSet.mem tool_name !tools
27
-
28
-
let list () =
29
-
if StringSet.is_empty !tools then
30
-
Log.app (fun m -> m "No permissions granted yet")
31
-
else
32
-
Log.app (fun m ->
33
-
m "Currently granted permissions: %s"
34
-
(StringSet.elements !tools |> String.concat ", "))
35
-
end
36
-
37
-
(* Interactive permission callback *)
38
-
let interactive_permission_callback ctx =
39
-
let open Claude.Permissions in
40
-
let tool_name = ctx.tool_name in
41
-
let input = ctx.input in
42
-
43
-
Log.info (fun m -> m "🔔 Permission callback invoked for tool: %s" tool_name);
44
-
Log.app (fun m -> m "\n🔐 PERMISSION REQUEST 🔐");
45
-
Log.app (fun m -> m "Tool: %s" tool_name);
46
-
47
-
(* Log the full input for debugging *)
48
-
let input_json = Claude.Tool_input.to_json input in
49
-
Log.info (fun m ->
50
-
m "Full input JSON: %s" (Test_json_utils.to_string input_json));
51
-
52
-
(* Show input details *)
53
-
(* Try to extract key information from the input *)
54
-
(try
55
-
match tool_name with
56
-
| "Read" -> (
57
-
match Test_json_utils.get_string input_json "file_path" with
58
-
| Some file_path -> Log.app (fun m -> m "File: %s" file_path)
59
-
| None -> ())
60
-
| "Bash" -> (
61
-
match Test_json_utils.get_string input_json "command" with
62
-
| Some command -> Log.app (fun m -> m "Command: %s" command)
63
-
| None -> ())
64
-
| "Write" | "Edit" -> (
65
-
match Test_json_utils.get_string input_json "file_path" with
66
-
| Some file_path -> Log.app (fun m -> m "File: %s" file_path)
67
-
| None -> ())
68
-
| "Glob" -> (
69
-
match Test_json_utils.get_string input_json "pattern" with
70
-
| Some pattern -> (
71
-
Log.app (fun m -> m "Pattern: %s" pattern);
72
-
match Test_json_utils.get_string input_json "path" with
73
-
| Some path -> Log.app (fun m -> m "Path: %s" path)
74
-
| None -> Log.app (fun m -> m "Path: (current directory)"))
75
-
| None -> ())
76
-
| "Grep" -> (
77
-
match Test_json_utils.get_string input_json "pattern" with
78
-
| Some pattern -> (
79
-
Log.app (fun m -> m "Pattern: %s" pattern);
80
-
match Test_json_utils.get_string input_json "path" with
81
-
| Some path -> Log.app (fun m -> m "Path: %s" path)
82
-
| None -> Log.app (fun m -> m "Path: (current directory)"))
83
-
| None -> ())
84
-
| _ ->
85
-
Log.app (fun m -> m "Input: %s" (Test_json_utils.to_string input_json))
86
-
with exn ->
87
-
Log.info (fun m ->
88
-
m "Failed to parse input details: %s" (Printexc.to_string exn)));
89
-
90
-
(* Check if already granted *)
91
-
if Granted.is_granted tool_name then begin
92
-
Log.app (fun m -> m "→ Auto-approved (previously granted)");
93
-
Log.info (fun m -> m "Returning allow result for %s" tool_name);
94
-
Decision.allow ()
95
-
end
96
-
else begin
97
-
(* Ask user - read from /dev/tty since stdin is connected to Claude process *)
98
-
Printf.printf "Allow? [y/N/always]: %!";
99
-
let tty = open_in "/dev/tty" in
100
-
let response = input_line tty |> String.lowercase_ascii in
101
-
close_in tty;
102
-
match response with
103
-
| "y" | "yes" ->
104
-
Log.app (fun m -> m "→ Allowed (this time only)");
105
-
Log.info (fun m -> m "User approved %s for this request only" tool_name);
106
-
Decision.allow ()
107
-
| "a" | "always" ->
108
-
Granted.grant tool_name;
109
-
Log.info (fun m ->
110
-
m "User granted permanent permission for %s" tool_name);
111
-
Decision.allow ()
112
-
| _ ->
113
-
Granted.deny tool_name;
114
-
Log.info (fun m -> m "User denied permission for %s" tool_name);
115
-
Decision.deny
116
-
~message:(Printf.sprintf "User denied access to %s" tool_name)
117
-
~interrupt:false
118
-
end
119
-
120
-
let process_response client =
121
-
let responses = Claude.Client.receive_all client in
122
-
List.iter
123
-
(fun response ->
124
-
match response with
125
-
| Claude.Response.Text t ->
126
-
let text = Claude.Response.Text.content t in
127
-
Log.app (fun m -> m "\n📝 Claude says:\n%s" text)
128
-
| Claude.Response.Tool_use t ->
129
-
Log.info (fun m ->
130
-
m "🔧 Tool use: %s (id: %s)"
131
-
(Claude.Response.Tool_use.name t)
132
-
(Claude.Response.Tool_use.id t))
133
-
| Claude.Response.Complete c ->
134
-
(if Claude.Response.Complete.result_text c = None then
135
-
Log.err (fun m -> m "❌ Error occurred!")
136
-
else
137
-
match Claude.Response.Complete.total_cost_usd c with
138
-
| Some cost -> Log.info (fun m -> m "💰 Cost: $%.6f" cost)
139
-
| None -> ());
140
-
Log.info (fun m ->
141
-
m "⏱️ Duration: %dms" (Claude.Response.Complete.duration_ms c))
142
-
| Claude.Response.Error e ->
143
-
Log.err (fun m -> m "❌ Error: %s" (Claude.Response.Error.message e))
144
-
| _ -> ())
145
-
responses
146
-
147
-
let run_demo ~sw ~env =
148
-
Log.app (fun m -> m "🚀 Starting Permission Demo");
149
-
Log.app (fun m -> m "==================================");
150
-
Log.app (fun m -> m "This demo starts with NO permissions.");
151
-
Log.app (fun m -> m "Claude will request permissions as needed.\n");
152
-
153
-
(* Create options with custom permission callback *)
154
-
(* DON'T specify allowed_tools - let the permission callback handle everything.
155
-
The Default permission mode with a callback should send requests for all tools. *)
156
-
let options =
157
-
Claude.Options.default
158
-
|> Claude.Options.with_model (Claude.Model.of_string "sonnet")
159
-
|> Claude.Options.with_permission_mode Claude.Permissions.Mode.Default
160
-
|> Claude.Options.with_permission_callback interactive_permission_callback
161
-
in
162
-
163
-
let client =
164
-
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr
165
-
~clock:env#clock ()
166
-
in
167
-
168
-
(* First prompt - Claude will need to request Read permission for ../lib *)
169
-
Log.app (fun m -> m "\n📤 Sending first prompt (reading from ../lib)...");
170
-
Claude.Client.query client
171
-
"Please read and analyze the source files in the ../lib directory. Focus \
172
-
on the main OCaml modules and their purpose. What is the overall \
173
-
architecture of this Claude library?";
174
-
process_response client;
175
-
176
-
(* Show current permissions *)
177
-
Log.app (fun m -> m "\n📋 Current permission status:");
178
-
Granted.list ();
179
-
180
-
(* Second prompt - will need Write permission *)
181
-
Log.app (fun m -> m "\n📤 Sending second prompt (writing TEST.md)...");
182
-
Claude.Client.query client
183
-
"Now write a summary of what you learned about the Claude library \
184
-
architecture to a file called TEST.md in the current directory. Include \
185
-
the main modules, their purposes, and how they work together.";
186
-
process_response client;
187
-
188
-
(* Show final permissions *)
189
-
Log.app (fun m -> m "\n📋 Final permission status:");
190
-
Granted.list ();
191
-
192
-
Log.app (fun m -> m "\n==================================");
193
-
Log.app (fun m -> m "✨ Demo complete!")
194
-
195
-
let main ~env = Switch.run @@ fun sw -> run_demo ~sw ~env
196
-
197
-
(* Command-line interface *)
198
-
open Cmdliner
199
-
200
-
let main_term env =
201
-
let setup_log style_renderer level =
202
-
Fmt_tty.setup_std_outputs ?style_renderer ();
203
-
Logs.set_level level;
204
-
Logs.set_reporter (Logs_fmt.reporter ());
205
-
(* Set default to App level if not specified *)
206
-
if level = None then Logs.set_level (Some Logs.App);
207
-
(* Enable info level for Client module if in info mode or above *)
208
-
match level with
209
-
| Some Logs.Info | Some Logs.Debug ->
210
-
Logs.Src.set_level Claude.Client.src (Some Logs.Info)
211
-
| _ -> ()
212
-
in
213
-
let run style level =
214
-
setup_log style level;
215
-
main ~env
216
-
in
217
-
Term.(const run $ Fmt_cli.style_renderer () $ Logs_cli.level ())
218
-
219
-
let cmd env =
220
-
let doc = "Demonstrate Claude's dynamic permission system" in
221
-
let man =
222
-
[
223
-
`S Manpage.s_description;
224
-
`P
225
-
"This program demonstrates how to use permission callbacks with Claude.";
226
-
`P "It starts with no permissions and asks for them interactively.";
227
-
`P "You can grant permissions for:";
228
-
`P "- Individual requests (y/yes)";
229
-
`P "- All future requests of that type (a/always)";
230
-
`P "- Or deny the request (n/no or just press Enter)";
231
-
`S Manpage.s_examples;
232
-
`P "Run the demo:";
233
-
`Pre " $(mname)";
234
-
`P "Run with verbose output to see message flow:";
235
-
`Pre " $(mname) -v";
236
-
`S Manpage.s_bugs;
237
-
`P "Report bugs at https://github.com/your-repo/issues";
238
-
]
239
-
in
240
-
let info = Cmd.info "permission_demo" ~version:"1.0" ~doc ~man in
241
-
Cmd.v info (main_term env)
242
-
243
-
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
-185
test/permission_demo.py
-185
test/permission_demo.py
···
1
-
#!/usr/bin/env python3
2
-
# /// script
3
-
# requires-python = ">=3.9"
4
-
# dependencies = [
5
-
# "claude-code-sdk",
6
-
# ]
7
-
# ///
8
-
"""
9
-
Permission demo for Claude Code SDK Python.
10
-
Demonstrates how the permission callback system works.
11
-
"""
12
-
13
-
import asyncio
14
-
import sys
15
-
import logging
16
-
from typing import Any, Dict
17
-
18
-
from claude_code_sdk import ClaudeSDKClient, ClaudeCodeOptions
19
-
from claude_code_sdk.types import (
20
-
PermissionResultAllow,
21
-
PermissionResultDeny,
22
-
ToolPermissionContext,
23
-
)
24
-
25
-
# Set up logging
26
-
logging.basicConfig(
27
-
level=logging.INFO,
28
-
format='%(asctime)s - %(name)s - %(levelname)s - %(message)s'
29
-
)
30
-
logger = logging.getLogger(__name__)
31
-
32
-
# Track granted permissions
33
-
granted_permissions = set()
34
-
35
-
36
-
async def interactive_permission_callback(
37
-
tool_name: str,
38
-
tool_input: Dict[str, Any],
39
-
context: ToolPermissionContext
40
-
) -> PermissionResultAllow | PermissionResultDeny:
41
-
"""Interactive permission callback that asks user for permission."""
42
-
43
-
logger.info(f"🔔 Permission callback invoked for tool: {tool_name}")
44
-
print(f"\n🔐 PERMISSION REQUEST 🔐")
45
-
print(f"Tool: {tool_name}")
46
-
47
-
# Log the full input for debugging
48
-
logger.info(f"Full input: {tool_input}")
49
-
50
-
# Show input details
51
-
try:
52
-
if tool_name == "Read":
53
-
file_path = tool_input.get("file_path", "")
54
-
print(f"File: {file_path}")
55
-
elif tool_name == "Bash":
56
-
command = tool_input.get("command", "")
57
-
print(f"Command: {command}")
58
-
elif tool_name in ["Write", "Edit"]:
59
-
file_path = tool_input.get("file_path", "")
60
-
print(f"File: {file_path}")
61
-
elif tool_name == "Glob":
62
-
pattern = tool_input.get("pattern", "")
63
-
path = tool_input.get("path", "(current directory)")
64
-
print(f"Pattern: {pattern}")
65
-
print(f"Path: {path}")
66
-
elif tool_name == "Grep":
67
-
pattern = tool_input.get("pattern", "")
68
-
path = tool_input.get("path", "(current directory)")
69
-
print(f"Pattern: {pattern}")
70
-
print(f"Path: {path}")
71
-
else:
72
-
print(f"Input: {tool_input}")
73
-
except Exception as e:
74
-
logger.info(f"Failed to parse input details: {e}")
75
-
76
-
# Check if already granted
77
-
if tool_name in granted_permissions:
78
-
print("→ Auto-approved (previously granted)")
79
-
logger.info(f"Returning allow result for {tool_name}")
80
-
return PermissionResultAllow()
81
-
82
-
# Ask user
83
-
response = input("Allow? [y/N/always]: ").lower().strip()
84
-
85
-
if response in ["y", "yes"]:
86
-
print("→ Allowed (this time only)")
87
-
logger.info(f"User approved {tool_name} for this request only")
88
-
return PermissionResultAllow()
89
-
elif response in ["a", "always"]:
90
-
granted_permissions.add(tool_name)
91
-
print(f"✅ Permission granted for: {tool_name}")
92
-
logger.info(f"User granted permanent permission for {tool_name}")
93
-
return PermissionResultAllow()
94
-
else:
95
-
print(f"❌ Permission denied for: {tool_name}")
96
-
logger.info(f"User denied permission for {tool_name}")
97
-
return PermissionResultDeny(
98
-
message=f"User denied access to {tool_name}",
99
-
interrupt=False
100
-
)
101
-
102
-
103
-
async def run_demo():
104
-
"""Run the permission demo."""
105
-
print("🚀 Starting Permission Demo")
106
-
print("==================================")
107
-
print("This demo starts with NO permissions.")
108
-
print("Claude will request permissions as needed.\n")
109
-
110
-
# Create options with custom permission callback
111
-
# Test WITHOUT allowed_tools to see if permission requests come through
112
-
options = ClaudeCodeOptions(
113
-
model="sonnet",
114
-
# allowed_tools=["Read", "Write", "Bash", "Edit", "Glob", "Grep"],
115
-
can_use_tool=interactive_permission_callback,
116
-
)
117
-
118
-
async with ClaudeSDKClient(options=options) as client:
119
-
# First prompt - Claude will need to request Read permission
120
-
print("\n📤 Sending first prompt (reading from ../lib)...")
121
-
messages = []
122
-
await client.query(
123
-
"Please read and analyze the source files in the ../lib directory. "
124
-
"Focus on the main OCaml modules and their purpose. "
125
-
"What is the overall architecture of this Claude library?"
126
-
)
127
-
128
-
async for msg in client.receive_response():
129
-
messages.append(msg)
130
-
if hasattr(msg, 'content'):
131
-
if isinstance(msg.content, str):
132
-
print(f"\n📝 Claude says:\n{msg.content}")
133
-
elif isinstance(msg.content, list):
134
-
for block in msg.content:
135
-
if hasattr(block, 'text'):
136
-
print(f"\n📝 Claude says:\n{block.text}")
137
-
138
-
# Show current permissions
139
-
print("\n📋 Current permission status:")
140
-
if granted_permissions:
141
-
print(f"Currently granted permissions: {', '.join(granted_permissions)}")
142
-
else:
143
-
print("No permissions granted yet")
144
-
145
-
# Second prompt - will need Write permission
146
-
print("\n📤 Sending second prompt (writing TEST.md)...")
147
-
await client.query(
148
-
"Now write a summary of what you learned about the Claude library "
149
-
"architecture to a file called TEST.md in the current directory. "
150
-
"Include the main modules, their purposes, and how they work together."
151
-
)
152
-
153
-
async for msg in client.receive_response():
154
-
if hasattr(msg, 'content'):
155
-
if isinstance(msg.content, str):
156
-
print(f"\n📝 Claude says:\n{msg.content}")
157
-
elif isinstance(msg.content, list):
158
-
for block in msg.content:
159
-
if hasattr(block, 'text'):
160
-
print(f"\n📝 Claude says:\n{block.text}")
161
-
162
-
# Show final permissions
163
-
print("\n📋 Final permission status:")
164
-
if granted_permissions:
165
-
print(f"Currently granted permissions: {', '.join(granted_permissions)}")
166
-
else:
167
-
print("No permissions granted yet")
168
-
169
-
print("\n==================================")
170
-
print("✨ Demo complete!")
171
-
172
-
173
-
async def main():
174
-
"""Main entry point."""
175
-
try:
176
-
await run_demo()
177
-
except KeyboardInterrupt:
178
-
print("\n\nDemo interrupted by user.")
179
-
except Exception as e:
180
-
logger.error(f"Error in demo: {e}", exc_info=True)
181
-
sys.exit(1)
182
-
183
-
184
-
if __name__ == "__main__":
185
-
asyncio.run(main())
-3
test/secret_data.txt
-3
test/secret_data.txt
-137
test/simple_permission_test.ml
-137
test/simple_permission_test.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
open Eio.Std
7
-
8
-
let src = Logs.Src.create "simple_permission_test" ~doc:"Simple permission test"
9
-
10
-
module Log = (val Logs.src_log src : Logs.LOG)
11
-
12
-
(* Auto-allow callback that logs what it sees *)
13
-
let auto_allow_callback ctx =
14
-
Log.app (fun m -> m "\n🔐 Permission callback invoked!");
15
-
Log.app (fun m -> m " Tool: %s" ctx.Claude.Permissions.tool_name);
16
-
Log.app (fun m ->
17
-
m " Input: %s"
18
-
(Test_json_utils.to_string
19
-
(Claude.Tool_input.to_json ctx.Claude.Permissions.input)));
20
-
Log.app (fun m -> m " ✅ Auto-allowing");
21
-
Claude.Permissions.Decision.allow ()
22
-
23
-
let run_test ~sw ~env =
24
-
Log.app (fun m -> m "🧪 Testing Permission Callbacks (Auto-Allow Mode)");
25
-
Log.app (fun m -> m "====================================================");
26
-
27
-
(* Create options with permission callback *)
28
-
let options =
29
-
Claude.Options.default
30
-
|> Claude.Options.with_model (Claude.Model.of_string "sonnet")
31
-
|> Claude.Options.with_permission_callback auto_allow_callback
32
-
in
33
-
34
-
Log.app (fun m -> m "Creating client with permission callback...");
35
-
let client =
36
-
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr
37
-
~clock:env#clock ()
38
-
in
39
-
40
-
(* Query that should trigger Write tool *)
41
-
Log.app (fun m -> m "\n📤 Asking Claude to write a file...");
42
-
Claude.Client.query client
43
-
"Write a simple hello world message to /tmp/test_permission.txt";
44
-
45
-
(* Process response *)
46
-
let messages = Claude.Client.receive_all client in
47
-
Log.app (fun m -> m "\n📨 Received %d messages" (List.length messages));
48
-
49
-
let tool_count = ref 0 in
50
-
let write_used = ref false in
51
-
52
-
List.iter
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 "\n💬 Claude: %s" content)
59
-
| Claude.Response.Tool_use t ->
60
-
incr tool_count;
61
-
let tool_name = Claude.Response.Tool_use.name t in
62
-
if tool_name = "Write" then write_used := true;
63
-
Log.app (fun m -> m "🔧 Tool use #%d: %s" !tool_count tool_name)
64
-
| Claude.Response.Tool_result r ->
65
-
let tool_use_id = Claude.Content_block.Tool_result.tool_use_id r in
66
-
let is_error =
67
-
Claude.Content_block.Tool_result.is_error r
68
-
|> Option.value ~default:false
69
-
in
70
-
if is_error then begin
71
-
Log.app (fun m -> m "\n⚠️ Tool result error for %s:" tool_use_id);
72
-
match Claude.Content_block.Tool_result.content r with
73
-
| Some json ->
74
-
let s =
75
-
match Jsont_bytesrw.encode_string' Jsont.json json with
76
-
| Ok str -> str
77
-
| Error _ -> "<encoding error>"
78
-
in
79
-
Log.app (fun m -> m " %s" s)
80
-
| None -> ()
81
-
end
82
-
| Claude.Response.Complete result ->
83
-
Log.app (fun m -> m "\n✅ Success!");
84
-
(match Claude.Response.Complete.total_cost_usd result with
85
-
| Some cost -> Log.app (fun m -> m "💰 Cost: $%.6f" cost)
86
-
| None -> ());
87
-
Log.app (fun m ->
88
-
m "⏱️ Duration: %dms"
89
-
(Claude.Response.Complete.duration_ms result))
90
-
| Claude.Response.Error err ->
91
-
Log.err (fun m ->
92
-
m "\n❌ Error: %s" (Claude.Response.Error.message err))
93
-
| _ -> ())
94
-
messages;
95
-
96
-
Log.app (fun m -> m "\n====================================================");
97
-
Log.app (fun m -> m "📊 Test Results:");
98
-
Log.app (fun m -> m " Total tools used: %d" !tool_count);
99
-
Log.app (fun m -> m " Write tool used: %b" !write_used);
100
-
101
-
if !write_used then
102
-
Log.app (fun m ->
103
-
m " ✅ Permission callback successfully intercepted Write tool!")
104
-
else Log.app (fun m -> m " ⚠️ Write tool was not used (unexpected)");
105
-
106
-
Log.app (fun m -> m "====================================================");
107
-
Log.app (fun m -> m "✨ Test complete!")
108
-
109
-
let main ~env = Switch.run @@ fun sw -> run_test ~sw ~env
110
-
111
-
(* Command-line interface *)
112
-
open Cmdliner
113
-
114
-
let main_term env =
115
-
let setup_log style_renderer level =
116
-
Fmt_tty.setup_std_outputs ?style_renderer ();
117
-
Logs.set_level level;
118
-
Logs.set_reporter (Logs_fmt.reporter ());
119
-
if level = None then Logs.set_level (Some Logs.App);
120
-
match level with
121
-
| Some Logs.Info | Some Logs.Debug ->
122
-
Logs.Src.set_level Claude.Client.src (Some Logs.Info);
123
-
Logs.Src.set_level Claude.Transport.src (Some Logs.Info)
124
-
| _ -> ()
125
-
in
126
-
let run style level =
127
-
setup_log style level;
128
-
main ~env
129
-
in
130
-
Term.(const run $ Fmt_cli.style_renderer () $ Logs_cli.level ())
131
-
132
-
let cmd env =
133
-
let doc = "Test permission callback with auto-allow" in
134
-
let info = Cmd.info "simple_permission_test" ~version:"1.0" ~doc in
135
-
Cmd.v info (main_term env)
136
-
137
-
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
-228
test/simulated_permissions.ml
-228
test/simulated_permissions.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
let src =
7
-
Logs.Src.create "simulated_permissions"
8
-
~doc:"Simulated permission demonstration"
9
-
10
-
module Log = (val Logs.src_log src : Logs.LOG)
11
-
12
-
(* Track granted permissions *)
13
-
module PermissionState = struct
14
-
module StringSet = Set.Make (String)
15
-
16
-
let granted = ref StringSet.empty
17
-
let denied = ref StringSet.empty
18
-
19
-
let grant tool =
20
-
granted := StringSet.add tool !granted;
21
-
denied := StringSet.remove tool !denied
22
-
23
-
let deny tool =
24
-
denied := StringSet.add tool !denied;
25
-
granted := StringSet.remove tool !granted
26
-
27
-
let is_granted tool = StringSet.mem tool !granted
28
-
let is_denied tool = StringSet.mem tool !denied
29
-
30
-
let _reset () =
31
-
granted := StringSet.empty;
32
-
denied := StringSet.empty
33
-
34
-
let show () =
35
-
Log.app (fun m -> m "\n📊 Permission Status:");
36
-
if StringSet.is_empty !granted && StringSet.is_empty !denied then
37
-
Log.app (fun m -> m " No permissions configured")
38
-
else begin
39
-
if not (StringSet.is_empty !granted) then
40
-
Log.app (fun m ->
41
-
m " ✅ Granted: %s"
42
-
(StringSet.elements !granted |> String.concat ", "));
43
-
if not (StringSet.is_empty !denied) then
44
-
Log.app (fun m ->
45
-
m " ❌ Denied: %s" (StringSet.elements !denied |> String.concat ", "))
46
-
end
47
-
end
48
-
49
-
(* Example permission callback *)
50
-
let example_permission_callback ctx =
51
-
let open Claude.Permissions in
52
-
let tool_name = ctx.tool_name in
53
-
54
-
Log.app (fun m -> m "\n🔐 Permission Request for: %s" tool_name);
55
-
56
-
(* Check current state *)
57
-
if PermissionState.is_granted tool_name then begin
58
-
Log.app (fun m -> m " → Auto-approved (previously granted)");
59
-
Decision.allow ()
60
-
end
61
-
else if PermissionState.is_denied tool_name then begin
62
-
Log.app (fun m -> m " → Auto-denied (previously denied)");
63
-
Decision.deny
64
-
~message:(Printf.sprintf "Tool %s is blocked by policy" tool_name)
65
-
~interrupt:false
66
-
end
67
-
else begin
68
-
(* Ask user *)
69
-
Printf.printf " Allow %s? [y/n/always/never]: %!" tool_name;
70
-
match read_line () |> String.lowercase_ascii with
71
-
| "y" | "yes" ->
72
-
Log.app (fun m -> m " → Allowed (one time)");
73
-
Decision.allow ()
74
-
| "n" | "no" ->
75
-
Log.app (fun m -> m " → Denied (one time)");
76
-
Decision.deny
77
-
~message:(Printf.sprintf "User denied %s" tool_name)
78
-
~interrupt:false
79
-
| "a" | "always" ->
80
-
PermissionState.grant tool_name;
81
-
Log.app (fun m -> m " → Allowed (always)");
82
-
Decision.allow ()
83
-
| "never" ->
84
-
PermissionState.deny tool_name;
85
-
Log.app (fun m -> m " → Denied (always)");
86
-
Decision.deny
87
-
~message:(Printf.sprintf "Tool %s permanently blocked" tool_name)
88
-
~interrupt:false
89
-
| _ ->
90
-
Log.app (fun m -> m " → Denied (invalid response)");
91
-
Decision.deny ~message:"Invalid permission response" ~interrupt:false
92
-
end
93
-
94
-
(* Demonstrate the permission system *)
95
-
let demo_permissions () =
96
-
Log.app (fun m -> m "🎭 Permission System Demonstration");
97
-
Log.app (fun m -> m "==================================\n");
98
-
99
-
(* Simulate permission requests *)
100
-
let tools = [ "Read"; "Write"; "Bash"; "Edit" ] in
101
-
102
-
Log.app (fun m -> m "This demo simulates permission requests.");
103
-
Log.app (fun m -> m "You can respond with: y/n/always/never\n");
104
-
105
-
(* Test each tool *)
106
-
List.iter
107
-
(fun tool_name ->
108
-
let input =
109
-
let open Jsont in
110
-
Object
111
-
( [
112
-
(("file_path", Meta.none), String ("/example/path.txt", Meta.none));
113
-
],
114
-
Meta.none )
115
-
in
116
-
let tool_input = Claude.Tool_input.of_json input in
117
-
let ctx =
118
-
Claude.Permissions.
119
-
{ tool_name; input = tool_input; suggested_rules = [] }
120
-
in
121
-
let decision = example_permission_callback ctx in
122
-
123
-
(* Show result *)
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))
133
-
tools;
134
-
135
-
(* Show final state *)
136
-
PermissionState.show ()
137
-
138
-
(* Also demonstrate discovery callback *)
139
-
let demo_discovery () =
140
-
Log.app (fun m -> m "\n\n🔍 Discovery Callback Demonstration");
141
-
Log.app (fun m -> m "====================================\n");
142
-
143
-
let discovered = ref [] in
144
-
let callback = Claude.Permissions.discovery discovered in
145
-
146
-
(* Simulate some tool requests *)
147
-
let requests =
148
-
let open Jsont in
149
-
[
150
-
( "Read",
151
-
Object
152
-
( [ (("file_path", Meta.none), String ("test.ml", Meta.none)) ],
153
-
Meta.none ) );
154
-
( "Bash",
155
-
Object
156
-
([ (("command", Meta.none), String ("ls -la", Meta.none)) ], Meta.none)
157
-
);
158
-
( "Write",
159
-
Object
160
-
( [ (("file_path", Meta.none), String ("output.txt", Meta.none)) ],
161
-
Meta.none ) );
162
-
]
163
-
in
164
-
165
-
Log.app (fun m -> m "Simulating tool requests with discovery callback...\n");
166
-
167
-
List.iter
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
-
{ tool_name; input = tool_input; suggested_rules = [] }
174
-
in
175
-
let _ = callback ctx in
176
-
())
177
-
requests;
178
-
179
-
Log.app (fun m -> m "\n📋 Discovered permissions:");
180
-
if !discovered = [] then Log.app (fun m -> m " None")
181
-
else
182
-
List.iter
183
-
(fun rule ->
184
-
Log.app (fun m ->
185
-
m " - %s%s"
186
-
(Claude.Permissions.Rule.tool_name rule)
187
-
(match Claude.Permissions.Rule.rule_content rule with
188
-
| Some content -> Printf.sprintf " (content: %s)" content
189
-
| None -> "")))
190
-
!discovered
191
-
192
-
let main () =
193
-
demo_permissions ();
194
-
demo_discovery ()
195
-
196
-
(* Command-line interface *)
197
-
open Cmdliner
198
-
199
-
let main_term =
200
-
let setup_log style_renderer level =
201
-
Fmt_tty.setup_std_outputs ?style_renderer ();
202
-
Logs.set_level level;
203
-
Logs.set_reporter (Logs_fmt.reporter ());
204
-
if level = None then Logs.set_level (Some Logs.App)
205
-
in
206
-
let run style level =
207
-
setup_log style level;
208
-
main ()
209
-
in
210
-
Term.(const run $ Fmt_cli.style_renderer () $ Logs_cli.level ())
211
-
212
-
let cmd =
213
-
let doc = "Demonstrate permission callbacks and discovery" in
214
-
let man =
215
-
[
216
-
`S Manpage.s_description;
217
-
`P
218
-
"This program demonstrates how permission callbacks work in the Claude \
219
-
OCaml library.";
220
-
`P
221
-
"It simulates permission requests and shows how to implement custom \
222
-
callbacks.";
223
-
]
224
-
in
225
-
let info = Cmd.info "simulated_permissions" ~version:"1.0" ~doc ~man in
226
-
Cmd.v info main_term
227
-
228
-
let () = exit (Cmd.eval cmd)
-228
test/structured_output_demo.ml
-228
test/structured_output_demo.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(* Example demonstrating structured output with JSON Schema *)
7
-
8
-
module C = Claude
9
-
10
-
let () =
11
-
(* Configure logging to see what's happening *)
12
-
Logs.set_reporter (Logs_fmt.reporter ());
13
-
Logs.set_level (Some Logs.Info);
14
-
Logs.Src.set_level C.Message.src (Some Logs.Debug)
15
-
16
-
let run_codebase_analysis env =
17
-
Printf.printf "\n=== Codebase Analysis with Structured Output ===\n\n";
18
-
19
-
(* Define the JSON Schema for our expected output structure *)
20
-
let analysis_schema =
21
-
let open Jsont in
22
-
Object
23
-
( [
24
-
(("type", Meta.none), String ("object", Meta.none));
25
-
( ("properties", Meta.none),
26
-
Object
27
-
( [
28
-
( ("file_count", Meta.none),
29
-
Object
30
-
( [
31
-
(("type", Meta.none), String ("integer", Meta.none));
32
-
( ("description", Meta.none),
33
-
String ("Total number of files analyzed", Meta.none)
34
-
);
35
-
],
36
-
Meta.none ) );
37
-
( ("has_tests", Meta.none),
38
-
Object
39
-
( [
40
-
(("type", Meta.none), String ("boolean", Meta.none));
41
-
( ("description", Meta.none),
42
-
String
43
-
("Whether the codebase has test files", Meta.none)
44
-
);
45
-
],
46
-
Meta.none ) );
47
-
( ("primary_language", Meta.none),
48
-
Object
49
-
( [
50
-
(("type", Meta.none), String ("string", Meta.none));
51
-
( ("description", Meta.none),
52
-
String
53
-
( "The primary programming language used",
54
-
Meta.none ) );
55
-
],
56
-
Meta.none ) );
57
-
( ("complexity_rating", Meta.none),
58
-
Object
59
-
( [
60
-
(("type", Meta.none), String ("string", Meta.none));
61
-
( ("enum", Meta.none),
62
-
Array
63
-
( [
64
-
String ("low", Meta.none);
65
-
String ("medium", Meta.none);
66
-
String ("high", Meta.none);
67
-
],
68
-
Meta.none ) );
69
-
( ("description", Meta.none),
70
-
String ("Overall complexity rating", Meta.none) );
71
-
],
72
-
Meta.none ) );
73
-
( ("key_findings", Meta.none),
74
-
Object
75
-
( [
76
-
(("type", Meta.none), String ("array", Meta.none));
77
-
( ("items", Meta.none),
78
-
Object
79
-
( [
80
-
( ("type", Meta.none),
81
-
String ("string", Meta.none) );
82
-
],
83
-
Meta.none ) );
84
-
( ("description", Meta.none),
85
-
String
86
-
( "List of key findings from the analysis",
87
-
Meta.none ) );
88
-
],
89
-
Meta.none ) );
90
-
],
91
-
Meta.none ) );
92
-
( ("required", Meta.none),
93
-
Array
94
-
( [
95
-
String ("file_count", Meta.none);
96
-
String ("has_tests", Meta.none);
97
-
String ("primary_language", Meta.none);
98
-
String ("complexity_rating", Meta.none);
99
-
String ("key_findings", Meta.none);
100
-
],
101
-
Meta.none ) );
102
-
(("additionalProperties", Meta.none), Bool (false, Meta.none));
103
-
],
104
-
Meta.none )
105
-
in
106
-
107
-
(* Create structured output format from the schema *)
108
-
let output_format =
109
-
Claude.Proto.Structured_output.of_json_schema analysis_schema
110
-
in
111
-
112
-
(* Configure Claude with structured output *)
113
-
let options =
114
-
C.Options.default
115
-
|> C.Options.with_output_format output_format
116
-
|> C.Options.with_allowed_tools [ "Read"; "Glob"; "Grep" ]
117
-
|> C.Options.with_system_prompt
118
-
"You are a code analysis assistant. Analyze codebases and provide \
119
-
structured output matching the given JSON Schema."
120
-
in
121
-
122
-
Printf.printf "Structured output format configured\n";
123
-
Printf.printf "Schema: %s\n\n"
124
-
(Test_json_utils.to_string ~minify:false analysis_schema);
125
-
126
-
(* Create Claude client and query *)
127
-
Eio.Switch.run @@ fun sw ->
128
-
let process_mgr = Eio.Stdenv.process_mgr env in
129
-
let clock = Eio.Stdenv.clock env in
130
-
let client = C.Client.create ~sw ~process_mgr ~clock ~options () in
131
-
132
-
let prompt =
133
-
"Please analyze the current codebase structure. Look at the files, \
134
-
identify the primary language, count files, check for tests, assess \
135
-
complexity, and provide key findings. Return your analysis in the \
136
-
structured JSON format I specified."
137
-
in
138
-
139
-
Printf.printf "Sending query: %s\n\n" prompt;
140
-
C.Client.query client prompt;
141
-
142
-
(* Process responses *)
143
-
let responses = C.Client.receive client in
144
-
Seq.iter
145
-
(function
146
-
| C.Response.Text text ->
147
-
Printf.printf "\nAssistant text:\n";
148
-
Printf.printf " %s\n" (C.Response.Text.content text)
149
-
| C.Response.Tool_use tool ->
150
-
Printf.printf " Using tool: %s\n" (C.Response.Tool_use.name tool)
151
-
| C.Response.Complete result -> (
152
-
Printf.printf "\n=== Result ===\n";
153
-
Printf.printf "Duration: %dms\n"
154
-
(C.Response.Complete.duration_ms result);
155
-
Printf.printf "Cost: $%.4f\n"
156
-
(Option.value
157
-
(C.Response.Complete.total_cost_usd result)
158
-
~default:0.0);
159
-
160
-
(* Extract and display structured output *)
161
-
match C.Response.Complete.structured_output result with
162
-
| Some output ->
163
-
Printf.printf "\n=== Structured Output ===\n";
164
-
Printf.printf "%s\n\n"
165
-
(Test_json_utils.to_string ~minify:false output);
166
-
167
-
(* Parse the structured output *)
168
-
let file_count =
169
-
Test_json_utils.get_int output "file_count"
170
-
|> Option.value ~default:0
171
-
in
172
-
let has_tests =
173
-
Test_json_utils.get_bool output "has_tests"
174
-
|> Option.value ~default:false
175
-
in
176
-
let language =
177
-
Test_json_utils.get_string output "primary_language"
178
-
|> Option.value ~default:"unknown"
179
-
in
180
-
let complexity =
181
-
Test_json_utils.get_string output "complexity_rating"
182
-
|> Option.value ~default:"unknown"
183
-
in
184
-
let findings =
185
-
match Test_json_utils.get_array output "key_findings" with
186
-
| Some items ->
187
-
List.filter_map
188
-
(fun json -> Test_json_utils.as_string json)
189
-
items
190
-
| None -> []
191
-
in
192
-
193
-
Printf.printf "=== Parsed Analysis ===\n";
194
-
Printf.printf "File Count: %d\n" file_count;
195
-
Printf.printf "Has Tests: %b\n" has_tests;
196
-
Printf.printf "Primary Language: %s\n" language;
197
-
Printf.printf "Complexity: %s\n" complexity;
198
-
Printf.printf "Key Findings:\n";
199
-
List.iter
200
-
(fun finding -> Printf.printf " - %s\n" finding)
201
-
findings
202
-
| None -> (
203
-
Printf.printf "No structured output received\n";
204
-
match C.Response.Complete.result_text result with
205
-
| Some text -> Printf.printf "Text result: %s\n" text
206
-
| None -> ()))
207
-
| C.Response.Init _ -> Printf.printf "Session initialized\n"
208
-
| C.Response.Error err ->
209
-
Printf.printf "Error: %s\n" (C.Response.Error.message err)
210
-
| _ -> ())
211
-
responses;
212
-
213
-
Printf.printf "\nDone!\n"
214
-
215
-
let () =
216
-
Eio_main.run @@ fun env ->
217
-
try run_codebase_analysis env with
218
-
| C.Transport.CLI_not_found msg ->
219
-
Printf.eprintf "Error: Claude CLI not found\n%s\n" msg;
220
-
Printf.eprintf "Make sure 'claude' is installed and in your PATH\n";
221
-
exit 1
222
-
| C.Transport.Connection_error msg ->
223
-
Printf.eprintf "Connection error: %s\n" msg;
224
-
exit 1
225
-
| exn ->
226
-
Printf.eprintf "Unexpected error: %s\n" (Printexc.to_string exn);
227
-
Printexc.print_backtrace stderr;
228
-
exit 1
-93
test/structured_output_simple.ml
-93
test/structured_output_simple.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(* Simple example showing structured output with explicit JSON Schema *)
7
-
8
-
module C = Claude
9
-
10
-
let () =
11
-
Logs.set_reporter (Logs_fmt.reporter ());
12
-
Logs.set_level (Some Logs.Info)
13
-
14
-
let simple_example env =
15
-
Printf.printf "\n=== Simple Structured Output Example ===\n\n";
16
-
17
-
(* Define a simple schema for a person's info *)
18
-
let person_schema =
19
-
let open Jsont in
20
-
Object
21
-
( [
22
-
(("type", Meta.none), String ("object", Meta.none));
23
-
( ("properties", Meta.none),
24
-
Object
25
-
( [
26
-
( ("name", Meta.none),
27
-
Object
28
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
29
-
Meta.none ) );
30
-
( ("age", Meta.none),
31
-
Object
32
-
( [ (("type", Meta.none), String ("integer", Meta.none)) ],
33
-
Meta.none ) );
34
-
( ("occupation", Meta.none),
35
-
Object
36
-
( [ (("type", Meta.none), String ("string", Meta.none)) ],
37
-
Meta.none ) );
38
-
],
39
-
Meta.none ) );
40
-
( ("required", Meta.none),
41
-
Array
42
-
( [
43
-
String ("name", Meta.none);
44
-
String ("age", Meta.none);
45
-
String ("occupation", Meta.none);
46
-
],
47
-
Meta.none ) );
48
-
],
49
-
Meta.none )
50
-
in
51
-
52
-
let output_format =
53
-
Claude.Proto.Structured_output.of_json_schema person_schema
54
-
in
55
-
56
-
let options =
57
-
C.Options.default
58
-
|> C.Options.with_output_format output_format
59
-
|> C.Options.with_max_turns 1
60
-
in
61
-
62
-
Printf.printf "Asking Claude to provide structured data...\n\n";
63
-
64
-
Eio.Switch.run @@ fun sw ->
65
-
let process_mgr = Eio.Stdenv.process_mgr env in
66
-
let clock = Eio.Stdenv.clock env in
67
-
let client = C.Client.create ~sw ~process_mgr ~clock ~options () in
68
-
69
-
C.Client.query client
70
-
"Tell me about a famous computer scientist. Provide their name, age, and \
71
-
occupation in the exact JSON structure I specified.";
72
-
73
-
let responses = C.Client.receive_all client in
74
-
List.iter
75
-
(function
76
-
| C.Response.Complete result -> (
77
-
Printf.printf "Response received!\n";
78
-
match C.Response.Complete.structured_output result with
79
-
| Some json ->
80
-
Printf.printf "\nStructured Output:\n%s\n"
81
-
(Test_json_utils.to_string ~minify:false json)
82
-
| None -> Printf.printf "No structured output\n")
83
-
| C.Response.Error err ->
84
-
Printf.printf "Error: %s\n" (C.Response.Error.message err)
85
-
| _ -> ())
86
-
responses
87
-
88
-
let () =
89
-
Eio_main.run @@ fun env ->
90
-
try simple_example env
91
-
with exn ->
92
-
Printf.eprintf "Error: %s\n" (Printexc.to_string exn);
93
-
exit 1
-31
test/test_json_utils.ml
-31
test/test_json_utils.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(* Helper functions for JSON operations in tests using jsont codecs *)
7
-
8
-
let to_string ?(minify = false) json =
9
-
let format = if minify then Jsont.Minify else Jsont.Indent in
10
-
match Jsont_bytesrw.encode_string' ~format Jsont.json json with
11
-
| Ok s -> s
12
-
| Error err -> Jsont.Error.to_string err
13
-
14
-
(* Helper to decode an optional field with a given codec *)
15
-
let get_opt (type a) (codec : a Jsont.t) json key : a option =
16
-
let field_codec =
17
-
Jsont.Object.map ~kind:"field" (fun v -> v)
18
-
|> Jsont.Object.opt_mem key codec ~enc:Fun.id
19
-
|> Jsont.Object.finish
20
-
in
21
-
match Jsont.Json.decode field_codec json with Ok v -> v | Error _ -> None
22
-
23
-
let get_string json key = get_opt Jsont.string json key
24
-
let get_int json key = get_opt Jsont.int json key
25
-
let get_bool json key = get_opt Jsont.bool json key
26
-
let get_array json key = get_opt (Jsont.list Jsont.json) json key
27
-
28
-
let as_string json =
29
-
match Jsont.Json.decode Jsont.string json with
30
-
| Ok s -> Some s
31
-
| Error _ -> None
-283
test/test_structured_error.ml
-283
test/test_structured_error.ml
···
1
-
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
5
-
6
-
(** Test structured errors by provoking a JSON-RPC error from Claude *)
7
-
8
-
open Eio.Std
9
-
10
-
let test_create_error_detail () =
11
-
print_endline "\nTesting structured error creation...";
12
-
13
-
(* Create a simple error *)
14
-
let error1 =
15
-
Proto.Control.Response.error_detail ~code:`Method_not_found
16
-
~message:"Method not found" ()
17
-
in
18
-
Printf.printf "✓ Created error: [%d] %s\n" error1.code error1.message;
19
-
20
-
(* Create an error without additional data for simplicity *)
21
-
let error2 =
22
-
Proto.Control.Response.error_detail ~code:`Invalid_params
23
-
~message:"Invalid parameters" ()
24
-
in
25
-
Printf.printf "✓ Created error: [%d] %s\n" error2.code error2.message;
26
-
27
-
(* Encode and decode an error response *)
28
-
let error_resp =
29
-
Proto.Control.Response.error ~request_id:"test-123" ~error:error2 ()
30
-
in
31
-
32
-
match Jsont.Json.encode Proto.Control.Response.jsont error_resp with
33
-
| Ok json -> (
34
-
let json_str =
35
-
match Jsont_bytesrw.encode_string' Jsont.json json with
36
-
| Ok s -> s
37
-
| Error e -> Jsont.Error.to_string e
38
-
in
39
-
Printf.printf "✓ Encoded error response: %s\n" json_str;
40
-
41
-
(* Decode it back *)
42
-
match Jsont.Json.decode Proto.Control.Response.jsont json with
43
-
| Ok (Proto.Control.Response.Error decoded) ->
44
-
Printf.printf "✓ Decoded error: [%d] %s\n" decoded.error.code
45
-
decoded.error.message
46
-
| Ok _ -> print_endline "✗ Wrong response type"
47
-
| Error e -> Printf.printf "✗ Decode failed: %s\n" e)
48
-
| Error e -> Printf.printf "✗ Encode failed: %s\n" e
49
-
50
-
let test_error_code_conventions () =
51
-
print_endline "\nTesting JSON-RPC error code conventions...";
52
-
53
-
(* Standard JSON-RPC errors using the typed API with polymorphic variants *)
54
-
let errors =
55
-
[
56
-
(`Parse_error, "Parse error");
57
-
(`Invalid_request, "Invalid request");
58
-
(`Method_not_found, "Method not found");
59
-
(`Invalid_params, "Invalid params");
60
-
(`Internal_error, "Internal error");
61
-
(`Custom 1, "Application error");
62
-
]
63
-
in
64
-
65
-
List.iter
66
-
(fun (code, msg) ->
67
-
let err = Proto.Control.Response.error_detail ~code ~message:msg () in
68
-
Printf.printf "✓ Error [%d]: %s (typed)\n" err.code err.message)
69
-
errors
70
-
71
-
let test_provoke_api_error ~sw ~env =
72
-
print_endline "\nTesting API error from Claude...";
73
-
74
-
(* Configure client with an invalid model to provoke an API error *)
75
-
let options =
76
-
Claude.Options.default
77
-
|> Claude.Options.with_model
78
-
(Claude.Model.of_string "invalid-model-that-does-not-exist")
79
-
in
80
-
81
-
Printf.printf "Creating client with invalid model...\n";
82
-
83
-
try
84
-
let client =
85
-
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr
86
-
~clock:env#clock ()
87
-
in
88
-
89
-
Printf.printf "Sending query to provoke API error...\n";
90
-
Claude.Client.query client
91
-
"Hello, this should fail with an invalid model error";
92
-
93
-
(* Process responses to see if we get an error *)
94
-
let messages = Claude.Client.receive_all client in
95
-
96
-
let error_found = ref false in
97
-
let text_error_found = ref false in
98
-
List.iter
99
-
(fun resp ->
100
-
match resp with
101
-
| Claude.Response.Error err ->
102
-
error_found := true;
103
-
Printf.printf "✓ Received structured error response: %s\n"
104
-
(Claude.Response.Error.message err);
105
-
Printf.printf " Is system error: %b\n"
106
-
(Claude.Response.Error.is_system_error err);
107
-
Printf.printf " Is assistant error: %b\n"
108
-
(Claude.Response.Error.is_assistant_error err)
109
-
| Claude.Response.Text text ->
110
-
let content = Claude.Response.Text.content text in
111
-
if
112
-
String.length content > 0
113
-
&& (String.contains content '4' || String.contains content 'e')
114
-
then begin
115
-
text_error_found := true;
116
-
Printf.printf "✓ Received error as text: %s\n" content
117
-
end
118
-
| Claude.Response.Complete result ->
119
-
Printf.printf " Complete (duration: %dms)\n"
120
-
(Claude.Response.Complete.duration_ms result)
121
-
| _ -> ())
122
-
messages;
123
-
124
-
if !error_found then
125
-
Printf.printf "✓ Successfully caught structured error response\n"
126
-
else if !text_error_found then
127
-
Printf.printf "✓ Successfully caught error (returned as text)\n"
128
-
else Printf.printf "✗ No error was returned (unexpected)\n"
129
-
with
130
-
| Claude.Transport.Connection_error msg ->
131
-
Printf.printf "✓ Connection error as expected: %s\n" msg
132
-
| exn ->
133
-
Printf.printf "✗ Unexpected exception: %s\n" (Printexc.to_string exn);
134
-
Printexc.print_backtrace stdout
135
-
136
-
let test_control_protocol_error () =
137
-
print_endline "\nTesting control protocol error encoding/decoding...";
138
-
139
-
(* Test that we can create and encode a control protocol error using polymorphic variant codes *)
140
-
let error_detail =
141
-
Proto.Control.Response.error_detail ~code:`Invalid_params
142
-
~message:"Invalid params for permission request"
143
-
~data:
144
-
(Jsont.Object
145
-
( [
146
-
( ("tool_name", Jsont.Meta.none),
147
-
Jsont.String ("Write", Jsont.Meta.none) );
148
-
( ("reason", Jsont.Meta.none),
149
-
Jsont.String
150
-
("Missing required file_path parameter", Jsont.Meta.none) );
151
-
],
152
-
Jsont.Meta.none ))
153
-
()
154
-
in
155
-
156
-
let error_response =
157
-
Proto.Control.Response.error ~request_id:"test-req-456" ~error:error_detail
158
-
()
159
-
in
160
-
161
-
match Jsont.Json.encode Proto.Control.Response.jsont error_response with
162
-
| Ok json -> (
163
-
let json_str =
164
-
match Jsont_bytesrw.encode_string' Jsont.json json with
165
-
| Ok s -> s
166
-
| Error e -> Jsont.Error.to_string e
167
-
in
168
-
Printf.printf "✓ Encoded control error with data:\n %s\n" json_str;
169
-
170
-
(* Verify we can decode it back *)
171
-
match Jsont.Json.decode Proto.Control.Response.jsont json with
172
-
| Ok (Proto.Control.Response.Error decoded) -> (
173
-
Printf.printf "✓ Decoded control error:\n";
174
-
Printf.printf " Code: %d\n" decoded.error.code;
175
-
Printf.printf " Message: %s\n" decoded.error.message;
176
-
Printf.printf " Has data: %b\n" (Option.is_some decoded.error.data);
177
-
match decoded.error.data with
178
-
| Some data ->
179
-
let data_str =
180
-
match Jsont_bytesrw.encode_string' Jsont.json data with
181
-
| Ok s -> s
182
-
| Error e -> Jsont.Error.to_string e
183
-
in
184
-
Printf.printf " Data: %s\n" data_str
185
-
| None -> ())
186
-
| Ok _ -> print_endline "✗ Wrong response type"
187
-
| Error e -> Printf.printf "✗ Decode failed: %s\n" e)
188
-
| Error e -> Printf.printf "✗ Encode failed: %s\n" e
189
-
190
-
let test_hook_error ~sw ~env =
191
-
print_endline "\nTesting hook callback errors trigger JSON-RPC error codes...";
192
-
193
-
(* Create a hook that will throw an exception *)
194
-
let failing_hook input =
195
-
Printf.printf "✓ Hook called for tool: %s\n"
196
-
input.Claude.Hooks.PreToolUse.tool_name;
197
-
failwith "Intentional hook failure to test error handling"
198
-
in
199
-
200
-
(* Register the failing hook *)
201
-
let hooks =
202
-
Claude.Hooks.empty
203
-
|> Claude.Hooks.on_pre_tool_use ~pattern:"Write" failing_hook
204
-
in
205
-
206
-
let options =
207
-
Claude.Options.default
208
-
|> Claude.Options.with_hooks hooks
209
-
|> Claude.Options.with_model (Claude.Model.of_string "haiku")
210
-
in
211
-
212
-
Printf.printf "Creating client with failing hook...\n";
213
-
214
-
try
215
-
let client =
216
-
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr
217
-
~clock:env#clock ()
218
-
in
219
-
220
-
Printf.printf
221
-
"Asking Claude to write a file (should trigger failing hook)...\n";
222
-
Claude.Client.query client "Write 'test' to /tmp/test_hook_error.txt";
223
-
224
-
(* Process responses *)
225
-
let messages = Claude.Client.receive_all client in
226
-
227
-
let hook_called = ref false in
228
-
let error_found = ref false in
229
-
List.iter
230
-
(fun resp ->
231
-
match resp with
232
-
| Claude.Response.Tool_use tool ->
233
-
let tool_name = Claude.Response.Tool_use.name tool in
234
-
if tool_name = "Write" then begin
235
-
hook_called := true;
236
-
Printf.printf "✓ Write tool was called (hook intercepted it)\n"
237
-
end
238
-
| Claude.Response.Error err ->
239
-
error_found := true;
240
-
Printf.printf " Error response: %s\n"
241
-
(Claude.Response.Error.message err)
242
-
| Claude.Response.Complete _ -> Printf.printf " Query completed\n"
243
-
| _ -> ())
244
-
messages;
245
-
246
-
if !hook_called then
247
-
Printf.printf "✓ Hook was triggered, exception caught by SDK\n"
248
-
else
249
-
Printf.printf
250
-
" Note: Hook may not have been called if query didn't use Write tool\n";
251
-
252
-
Printf.printf "✓ Test completed (SDK sent -32603 Internal Error to CLI)\n"
253
-
with exn ->
254
-
Printf.printf "Exception during test: %s\n" (Printexc.to_string exn);
255
-
Printexc.print_backtrace stdout
256
-
257
-
let run_all_tests env =
258
-
print_endline "=== Structured Error Tests ===";
259
-
test_create_error_detail ();
260
-
test_error_code_conventions ();
261
-
test_control_protocol_error ();
262
-
263
-
(* Test with actual Claude invocation *)
264
-
Switch.run @@ fun sw ->
265
-
test_provoke_api_error ~sw ~env;
266
-
267
-
(* Test hook errors that trigger JSON-RPC error codes *)
268
-
Switch.run @@ fun sw ->
269
-
test_hook_error ~sw ~env;
270
-
271
-
print_endline "\n=== All Structured Error Tests Completed ==="
272
-
273
-
let () =
274
-
Eio_main.run @@ fun env ->
275
-
try run_all_tests env with
276
-
| Claude.Transport.CLI_not_found msg ->
277
-
Printf.eprintf "Error: Claude CLI not found\n%s\n" msg;
278
-
Printf.eprintf "Make sure 'claude' is installed and in your PATH\n";
279
-
exit 1
280
-
| exn ->
281
-
Printf.eprintf "Fatal error: %s\n" (Printexc.to_string exn);
282
-
Printexc.print_backtrace stderr;
283
-
exit 1