OCaml Claude SDK using Eio and Jsont
claudeio: rename directory to ocaml-claude (matches package name)
Aligns the local subtree path with the opam package name (`claude`),
since `io` was redundant and the SDK no longer surfaces a separate
proto sublibrary.
- git mv ocaml-claudeio -> ocaml-claude
- sources.toml: section [ocaml-claude]; URLs still point at the
current upstream `ocaml-claudeio` on tangled.org (rename pending)
- llms.txt, README.md: paths updated
- lib/options.ml: log src claudeio.options -> claude.options
(matches every other src in the library)
- lib/err.{ml,mli}: doc comment dropped the old name
- test/interop/python_sdk/test.ml: regen-traces alias path
The dune-project source field and claude.opam URLs still point at
ocaml-claudeio. They will sync once the upstream remote is renamed.
+14324
+23
.gitignore
+23
.gitignore
···
1
+
# OCaml build artifacts
2
+
_build/
3
+
*.install
4
+
*.merlin
5
+
*.cmi
6
+
*.cmo
7
+
*.cmx
8
+
*.cmt
9
+
*.cmti
10
+
*.bak
11
+
12
+
# Third-party sources (fetch locally with opam source)
13
+
third_party/
14
+
15
+
# Editor and OS files
16
+
.DS_Store
17
+
*.swp
18
+
*~
19
+
.vscode/
20
+
.idea/
21
+
22
+
# Opam local switch
23
+
_opam/
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version = 0.29.0
+53
.tangled/workflows/build.yml
+53
.tangled/workflows/build.yml
···
1
+
when:
2
+
- event: ["push", "pull_request"]
3
+
branch: ["main"]
4
+
5
+
engine: nixery
6
+
7
+
dependencies:
8
+
nixpkgs:
9
+
- shell
10
+
- stdenv
11
+
- findutils
12
+
- binutils
13
+
- libunwind
14
+
- ncurses
15
+
- opam
16
+
- git
17
+
- gawk
18
+
- gnupatch
19
+
- gnum4
20
+
- gnumake
21
+
- gnutar
22
+
- gnused
23
+
- gnugrep
24
+
- diffutils
25
+
- gzip
26
+
- bzip2
27
+
- gcc
28
+
- ocaml
29
+
- pkg-config
30
+
31
+
steps:
32
+
- name: opam
33
+
command: |
34
+
opam init --disable-sandboxing -a -y
35
+
- name: repo
36
+
command: |
37
+
opam repo add aoah https://tangled.org/anil.recoil.org/aoah-opam-repo.git
38
+
- name: switch
39
+
command: |
40
+
opam install . --confirm-level=unsafe-yes --deps-only
41
+
- name: build
42
+
command: |
43
+
opam exec -- dune build -p claude
44
+
- name: switch-test
45
+
command: |
46
+
opam install . --confirm-level=unsafe-yes --deps-only --with-test
47
+
- name: test
48
+
command: |
49
+
opam exec -- dune runtest --verbose
50
+
- name: doc
51
+
command: |
52
+
opam install -y odoc
53
+
opam exec -- dune build @doc
+990
ARCHITECTURE.md
+990
ARCHITECTURE.md
···
1
+
# Claude OCaml SDK Architecture (v2)
2
+
3
+
This document describes the rearchitected OCaml SDK, aligned with the Python Claude Agent SDK while maintaining idiomatic OCaml/Eio patterns.
4
+
5
+
## Core Design Principles
6
+
7
+
### 1. MCP for Custom Tools (Python SDK Pattern)
8
+
9
+
The Python SDK's key insight: **built-in tools are handled by Claude CLI, custom tools via MCP**.
10
+
11
+
```
12
+
Claude CLI SDK (OCaml Process)
13
+
| |
14
+
|--[tool_use Read]--->| (CLI handles internally)
15
+
| |
16
+
|<--[tool_result]----|
17
+
| |
18
+
|--[mcp_request]----->| (SDK handles via in-process MCP)
19
+
|<--[mcp_response]----|
20
+
```
21
+
22
+
This eliminates the current problem where the OCaml SDK intercepts ALL tool_use events.
23
+
24
+
### 2. Hooks Intercept, Don't Execute
25
+
26
+
Hooks provide interception points for **observation and control**, not execution:
27
+
- PreToolUse: Allow/Deny/Modify before execution (by CLI or MCP)
28
+
- PostToolUse: Observe/Modify after execution
29
+
- Other lifecycle hooks remain the same
30
+
31
+
### 3. Two-Level API
32
+
33
+
Like Python, provide both simple and advanced interfaces:
34
+
- `Claude.query`: One-shot queries, simple async iterator
35
+
- `Claude.Client`: Full bidirectional, multi-turn, custom tools
36
+
37
+
---
38
+
39
+
## Module Structure
40
+
41
+
```
42
+
lib/
43
+
├── claude.ml # Main module, re-exports public API
44
+
├── claude.mli
45
+
│
46
+
├── client.ml # Bidirectional client
47
+
├── client.mli
48
+
│
49
+
├── tool.ml # Custom tool definition
50
+
├── tool.mli
51
+
│
52
+
├── mcp_server.ml # In-process MCP server
53
+
├── mcp_server.mli
54
+
│
55
+
├── hook.ml # Hook types and matchers
56
+
├── hook.mli
57
+
│
58
+
├── options.ml # Configuration
59
+
├── options.mli
60
+
│
61
+
├── message.ml # Message types
62
+
├── message.mli
63
+
│
64
+
├── response.ml # Response events
65
+
├── response.mli
66
+
│
67
+
├── model.ml # Model identifiers
68
+
├── model.mli
69
+
│
70
+
├── permission_mode.ml # Permission modes
71
+
├── permission_mode.mli
72
+
│
73
+
├── server_info.ml # Server metadata
74
+
├── server_info.mli
75
+
│
76
+
├── err.ml # Error types
77
+
├── err.mli
78
+
│
79
+
└── internal/
80
+
├── process.ml # CLI process management
81
+
├── protocol.ml # JSON wire protocol
82
+
└── mcp_handler.ml # MCP message routing
83
+
```
84
+
85
+
---
86
+
87
+
## Core Types
88
+
89
+
### Tool Definition
90
+
91
+
```ocaml
92
+
(* tool.mli *)
93
+
94
+
(** Custom tool for MCP servers.
95
+
96
+
Tools are functions that Claude can invoke. They run in-process
97
+
within your OCaml application via MCP protocol.
98
+
99
+
{[
100
+
let greet = Tool.create
101
+
~name:"greet"
102
+
~description:"Greet a user by name"
103
+
~input_schema:(`O ["name", `String "string"])
104
+
~handler:(fun args ->
105
+
match Jsont.find_string "name" args with
106
+
| Some name -> Ok (`String (Printf.sprintf "Hello, %s!" name))
107
+
| None -> Error "Missing 'name' parameter")
108
+
]} *)
109
+
110
+
type t
111
+
112
+
val create :
113
+
name:string ->
114
+
description:string ->
115
+
input_schema:Jsont.json ->
116
+
handler:(Jsont.json -> (Jsont.json, string) result) ->
117
+
t
118
+
(** [create ~name ~description ~input_schema ~handler] creates a custom tool.
119
+
120
+
@param name Unique tool identifier. Claude uses this in function calls.
121
+
@param description Human-readable description for Claude.
122
+
@param input_schema JSON Schema for input validation.
123
+
@param handler Function that executes the tool and returns result or error. *)
124
+
125
+
val name : t -> string
126
+
val description : t -> string
127
+
val input_schema : t -> Jsont.json
128
+
val call : t -> Jsont.json -> (Jsont.json, string) result
129
+
130
+
(** {2 Async Tools}
131
+
132
+
For tools that need Eio concurrency: *)
133
+
134
+
type async_t
135
+
136
+
val create_async :
137
+
name:string ->
138
+
description:string ->
139
+
input_schema:Jsont.json ->
140
+
handler:(sw:Eio.Switch.t -> Jsont.json -> (Jsont.json, string) result) ->
141
+
async_t
142
+
(** Create a tool that runs under an Eio switch for async operations. *)
143
+
```
144
+
145
+
### MCP Server
146
+
147
+
```ocaml
148
+
(* mcp_server.mli *)
149
+
150
+
(** In-process MCP server.
151
+
152
+
SDK MCP servers run directly in your OCaml application, eliminating
153
+
subprocess overhead. They handle tools/list and tools/call requests.
154
+
155
+
{[
156
+
let server = Mcp_server.create
157
+
~name:"my-tools"
158
+
~tools:[greet_tool; calculate_tool]
159
+
()
160
+
161
+
let options = Options.default
162
+
|> Options.with_mcp_server ~name:"tools" server
163
+
|> Options.with_allowed_tools ["mcp__tools__greet"]
164
+
]} *)
165
+
166
+
type t
167
+
168
+
val create :
169
+
name:string ->
170
+
?version:string ->
171
+
tools:Tool.t list ->
172
+
unit ->
173
+
t
174
+
(** [create ~name ?version ~tools ()] creates an in-process MCP server.
175
+
176
+
@param name Server identifier. Tools are accessed as [mcp__<name>__<tool>].
177
+
@param version Server version (default "1.0.0").
178
+
@param tools List of tools this server provides. *)
179
+
180
+
val name : t -> string
181
+
val version : t -> string
182
+
val tools : t -> Tool.t list
183
+
184
+
(** {2 MCP Protocol Handling} *)
185
+
186
+
val handle_request :
187
+
t ->
188
+
method_:string ->
189
+
params:Jsont.json ->
190
+
(Jsont.json, string) result
191
+
(** [handle_request t ~method_ ~params] handles MCP JSONRPC requests.
192
+
193
+
Supports:
194
+
- [initialize]: Returns server capabilities
195
+
- [tools/list]: Returns available tools
196
+
- [tools/call]: Executes a tool *)
197
+
```
198
+
199
+
### Hooks
200
+
201
+
```ocaml
202
+
(* hook.mli *)
203
+
204
+
(** Hook callbacks for event interception.
205
+
206
+
Hooks intercept events in the Claude agent loop. They can observe,
207
+
allow, deny, or modify tool execution.
208
+
209
+
{b Key difference from tool execution}: Hooks don't execute built-in
210
+
tools - Claude CLI handles those. Hooks only intercept for control.
211
+
212
+
{[
213
+
let block_rm = Hook.PreToolUse.handler (fun input ->
214
+
if input.tool_name = "Bash" then
215
+
match Tool_input.string input.tool_input "command" with
216
+
| Some cmd when String.is_substring cmd ~substring:"rm -rf" ->
217
+
Hook.PreToolUse.deny ~reason:"Dangerous command"
218
+
| _ -> Hook.PreToolUse.allow ()
219
+
else Hook.PreToolUse.allow ())
220
+
221
+
let hooks = Hook.Config.empty
222
+
|> Hook.Config.on_pre_tool_use ~pattern:"Bash" block_rm
223
+
]} *)
224
+
225
+
type context = {
226
+
session_id : string option;
227
+
transcript_path : string option;
228
+
}
229
+
(** Context provided to all hooks. *)
230
+
231
+
(** {1 PreToolUse Hook}
232
+
233
+
Fires before any tool execution (built-in or MCP). *)
234
+
module PreToolUse : sig
235
+
type input = {
236
+
tool_name : string;
237
+
tool_input : Tool_input.t;
238
+
context : context;
239
+
}
240
+
241
+
type decision =
242
+
| Allow
243
+
| Deny of { reason : string }
244
+
| Modify of { input : Tool_input.t }
245
+
| Ask of { reason : string option }
246
+
247
+
val allow : ?updated_input:Tool_input.t -> unit -> decision
248
+
val deny : reason:string -> decision
249
+
val ask : ?reason:string -> unit -> decision
250
+
val modify : input:Tool_input.t -> decision
251
+
252
+
type handler = input -> decision
253
+
254
+
val handler : (input -> decision) -> handler
255
+
end
256
+
257
+
(** {1 PostToolUse Hook}
258
+
259
+
Fires after tool execution completes. *)
260
+
module PostToolUse : sig
261
+
type input = {
262
+
tool_name : string;
263
+
tool_input : Tool_input.t;
264
+
tool_result : Jsont.json;
265
+
context : context;
266
+
}
267
+
268
+
type decision =
269
+
| Continue
270
+
| Block of { reason : string option }
271
+
| AddContext of { context : string }
272
+
273
+
val continue : unit -> decision
274
+
val block : ?reason:string -> unit -> decision
275
+
val add_context : string -> decision
276
+
277
+
type handler = input -> decision
278
+
end
279
+
280
+
(** {1 Other Hooks} *)
281
+
module UserPromptSubmit : sig
282
+
type input = { prompt : string; context : context }
283
+
type decision = Continue | Block of { reason : string option }
284
+
type handler = input -> decision
285
+
end
286
+
287
+
module Stop : sig
288
+
type input = { stop_hook_active : bool; context : context }
289
+
type decision = Continue | Block of { reason : string option }
290
+
type handler = input -> decision
291
+
end
292
+
293
+
module PreCompact : sig
294
+
type input = { context : context }
295
+
type handler = input -> unit (* Notification only *)
296
+
end
297
+
298
+
(** {1 Hook Configuration} *)
299
+
module Config : sig
300
+
type t
301
+
302
+
val empty : t
303
+
304
+
val on_pre_tool_use : ?pattern:string -> PreToolUse.handler -> t -> t
305
+
val on_post_tool_use : ?pattern:string -> PostToolUse.handler -> t -> t
306
+
val on_user_prompt_submit : UserPromptSubmit.handler -> t -> t
307
+
val on_stop : Stop.handler -> t -> t
308
+
val on_pre_compact : PreCompact.handler -> t -> t
309
+
end
310
+
```
311
+
312
+
### Options
313
+
314
+
```ocaml
315
+
(* options.mli *)
316
+
317
+
(** Configuration options for Claude sessions.
318
+
319
+
{[
320
+
let options = Options.default
321
+
|> Options.with_model Model.opus
322
+
|> Options.with_mcp_server ~name:"tools" my_server
323
+
|> Options.with_allowed_tools ["mcp__tools__greet"; "Read"; "Write"]
324
+
|> Options.with_hooks my_hooks
325
+
|> Options.with_max_budget_usd 1.0
326
+
]} *)
327
+
328
+
type t
329
+
330
+
val default : t
331
+
332
+
(** {1 Builder Pattern} *)
333
+
334
+
val with_system_prompt : string -> t -> t
335
+
val with_append_system_prompt : string -> t -> t
336
+
val with_model : Model.t -> t -> t
337
+
val with_fallback_model : Model.t -> t -> t
338
+
val with_max_turns : int -> t -> t
339
+
val with_max_thinking_tokens : int -> t -> t
340
+
val with_max_budget_usd : float -> t -> t
341
+
342
+
val with_allowed_tools : string list -> t -> t
343
+
val with_disallowed_tools : string list -> t -> t
344
+
val with_permission_mode : Permission_mode.t -> t -> t
345
+
346
+
val with_cwd : [> Eio.Fs.dir_ty ] Eio.Path.t -> t -> t
347
+
val with_env : (string * string) list -> t -> t
348
+
349
+
val with_mcp_server : name:string -> Mcp_server.t -> t -> t
350
+
(** Add an in-process MCP server. Multiple servers can be added. *)
351
+
352
+
val with_hooks : Hook.Config.t -> t -> t
353
+
354
+
val with_no_settings : t -> t
355
+
val with_cli_path : string -> t -> t
356
+
357
+
(** {1 Accessors} *)
358
+
359
+
val system_prompt : t -> string option
360
+
val model : t -> Model.t option
361
+
val mcp_servers : t -> (string * Mcp_server.t) list
362
+
val hooks : t -> Hook.Config.t option
363
+
(* ... other accessors ... *)
364
+
```
365
+
366
+
### Permission Mode
367
+
368
+
```ocaml
369
+
(* permission_mode.mli *)
370
+
371
+
(** Permission modes for tool authorization. *)
372
+
373
+
type t =
374
+
| Default (** Prompt for all permissions *)
375
+
| Accept_edits (** Auto-accept file edits *)
376
+
| Plan (** Planning mode - restricted execution *)
377
+
| Bypass (** Skip all permission checks - DANGEROUS *)
378
+
379
+
val to_string : t -> string
380
+
val of_string : string -> t option
381
+
```
382
+
383
+
### Model
384
+
385
+
```ocaml
386
+
(* model.mli *)
387
+
388
+
(** Claude AI model identifiers. *)
389
+
390
+
type t =
391
+
| Sonnet_4_5
392
+
| Opus_4
393
+
| Haiku_4
394
+
| Custom of string
395
+
396
+
val sonnet : t
397
+
val opus : t
398
+
val haiku : t
399
+
400
+
val to_string : t -> string
401
+
val of_string : string -> t
402
+
```
403
+
404
+
### Messages and Responses
405
+
406
+
```ocaml
407
+
(* message.mli *)
408
+
409
+
(** Messages exchanged with Claude. *)
410
+
411
+
module Content_block : sig
412
+
type t =
413
+
| Text of { text : string }
414
+
| Tool_use of { id : string; name : string; input : Jsont.json }
415
+
| Tool_result of { tool_use_id : string; content : Jsont.json; is_error : bool }
416
+
| Thinking of { text : string }
417
+
end
418
+
419
+
module User : sig
420
+
type t
421
+
val of_string : string -> t
422
+
val of_blocks : Content_block.t list -> t
423
+
val of_tool_results : (string * Jsont.json * bool) list -> t
424
+
end
425
+
426
+
module Assistant : sig
427
+
type t
428
+
val content : t -> Content_block.t list
429
+
val text : t -> string (* Concatenated text blocks *)
430
+
end
431
+
432
+
type t =
433
+
| User of User.t
434
+
| Assistant of Assistant.t
435
+
| System of { session_id : string option }
436
+
| Result of { text : string }
437
+
438
+
439
+
(* response.mli *)
440
+
441
+
(** Response events from Claude. *)
442
+
443
+
module Text : sig
444
+
type t
445
+
val content : t -> string
446
+
end
447
+
448
+
module Tool_use : sig
449
+
type t
450
+
val id : t -> string
451
+
val name : t -> string
452
+
val input : t -> Jsont.json
453
+
end
454
+
455
+
module Thinking : sig
456
+
type t
457
+
val content : t -> string
458
+
end
459
+
460
+
module Complete : sig
461
+
type t
462
+
val total_cost_usd : t -> float option
463
+
val input_tokens : t -> int
464
+
val output_tokens : t -> int
465
+
val duration_ms : t -> int option
466
+
end
467
+
468
+
module Init : sig
469
+
type t
470
+
val session_id : t -> string option
471
+
end
472
+
473
+
module Error : sig
474
+
type t
475
+
val message : t -> string
476
+
val code : t -> string option
477
+
end
478
+
479
+
type t =
480
+
| Text of Text.t
481
+
| Tool_use of Tool_use.t
482
+
| Thinking of Thinking.t
483
+
| Init of Init.t
484
+
| Error of Error.t
485
+
| Complete of Complete.t
486
+
```
487
+
488
+
---
489
+
490
+
## Client Interface
491
+
492
+
```ocaml
493
+
(* client.mli *)
494
+
495
+
(** Bidirectional client for Claude interactions.
496
+
497
+
The client handles:
498
+
- Message streaming via Eio
499
+
- MCP routing for custom tools
500
+
- Hook callbacks
501
+
- Permission requests
502
+
- Dynamic control (model/permission changes)
503
+
504
+
{2 Basic Usage}
505
+
506
+
{[
507
+
Eio.Switch.run @@ fun sw ->
508
+
let client = Client.create ~sw ~process_mgr ~clock () in
509
+
510
+
Client.query client "What is 2+2?";
511
+
512
+
Client.receive client |> Seq.iter (function
513
+
| Response.Text t -> print_endline (Response.Text.content t)
514
+
| Response.Complete c ->
515
+
Printf.printf "Cost: $%.4f\n"
516
+
(Option.value ~default:0.0 (Response.Complete.total_cost_usd c))
517
+
| _ -> ())
518
+
]}
519
+
520
+
{2 With Custom Tools}
521
+
522
+
{[
523
+
let greet = Tool.create
524
+
~name:"greet"
525
+
~description:"Greet someone"
526
+
~input_schema:(`O ["name", `String "string"])
527
+
~handler:(fun args -> Ok (`String "Hello!"))
528
+
529
+
let server = Mcp_server.create ~name:"tools" ~tools:[greet] ()
530
+
531
+
let options = Options.default
532
+
|> Options.with_mcp_server ~name:"tools" server
533
+
|> Options.with_allowed_tools ["mcp__tools__greet"]
534
+
535
+
let client = Client.create ~sw ~process_mgr ~clock ~options ()
536
+
]} *)
537
+
538
+
type t
539
+
540
+
val create :
541
+
sw:Eio.Switch.t ->
542
+
process_mgr:_ Eio.Process.mgr ->
543
+
clock:float Eio.Time.clock_ty Eio.Resource.t ->
544
+
?options:Options.t ->
545
+
unit ->
546
+
t
547
+
(** Create a new Claude client. *)
548
+
549
+
(** {1 Querying} *)
550
+
551
+
val query : t -> string -> unit
552
+
(** [query t prompt] sends a text prompt to Claude. *)
553
+
554
+
val send_message : t -> Message.User.t -> unit
555
+
(** [send_message t msg] sends a user message (can include tool results). *)
556
+
557
+
(** {1 Receiving Responses} *)
558
+
559
+
val receive : t -> Response.t Seq.t
560
+
(** [receive t] returns a lazy sequence of response events.
561
+
562
+
Built-in tool executions happen internally (by Claude CLI).
563
+
Custom tool calls are routed to MCP servers automatically.
564
+
You only see the responses. *)
565
+
566
+
val receive_all : t -> Response.t list
567
+
(** [receive_all t] collects all responses into a list. *)
568
+
569
+
(** {1 Dynamic Control} *)
570
+
571
+
val set_model : t -> Model.t -> unit
572
+
val set_permission_mode : t -> Permission_mode.t -> unit
573
+
val server_info : t -> Server_info.t
574
+
val interrupt : t -> unit
575
+
576
+
val session_id : t -> string option
577
+
(** Get session ID if available. *)
578
+
```
579
+
580
+
---
581
+
582
+
## Simple Query API
583
+
584
+
```ocaml
585
+
(* claude.mli *)
586
+
587
+
(** OCaml SDK for Claude Code CLI.
588
+
589
+
{1 Quick Start}
590
+
591
+
{[
592
+
open Eio.Std
593
+
594
+
let () = Eio_main.run @@ fun env ->
595
+
Switch.run @@ fun sw ->
596
+
let process_mgr = Eio.Stdenv.process_mgr env in
597
+
let clock = Eio.Stdenv.clock env in
598
+
599
+
(* Simple one-shot query *)
600
+
let response = Claude.query_text ~sw ~process_mgr ~clock
601
+
~prompt:"What is 2+2?" () in
602
+
print_endline response
603
+
]}
604
+
605
+
{1 With Custom Tools}
606
+
607
+
{[
608
+
let greet = Claude.Tool.create
609
+
~name:"greet"
610
+
~description:"Greet a user"
611
+
~input_schema:(`O ["name", `String "string"])
612
+
~handler:(fun args ->
613
+
Ok (`String (Printf.sprintf "Hello, %s!"
614
+
(Jsont.get_string_exn "name" args))))
615
+
616
+
let server = Claude.Mcp_server.create
617
+
~name:"my-tools"
618
+
~tools:[greet]
619
+
()
620
+
621
+
let options = Claude.Options.default
622
+
|> Claude.Options.with_mcp_server ~name:"tools" server
623
+
|> Claude.Options.with_allowed_tools ["mcp__tools__greet"]
624
+
625
+
let client = Claude.Client.create ~sw ~process_mgr ~clock ~options ()
626
+
]} *)
627
+
628
+
(** {1 Simple Query Functions} *)
629
+
630
+
val query :
631
+
sw:Eio.Switch.t ->
632
+
process_mgr:_ Eio.Process.mgr ->
633
+
clock:float Eio.Time.clock_ty Eio.Resource.t ->
634
+
?options:Options.t ->
635
+
prompt:string ->
636
+
unit ->
637
+
Response.t Seq.t
638
+
(** [query ~sw ~process_mgr ~clock ?options ~prompt ()] performs a one-shot query.
639
+
640
+
Returns a lazy sequence of response events. The client is created and
641
+
cleaned up automatically. *)
642
+
643
+
val query_text :
644
+
sw:Eio.Switch.t ->
645
+
process_mgr:_ Eio.Process.mgr ->
646
+
clock:float Eio.Time.clock_ty Eio.Resource.t ->
647
+
?options:Options.t ->
648
+
prompt:string ->
649
+
unit ->
650
+
string
651
+
(** [query_text ...] is like [query] but returns concatenated text response. *)
652
+
653
+
(** {1 Core Modules} *)
654
+
655
+
module Client = Client
656
+
module Options = Options
657
+
module Tool = Tool
658
+
module Mcp_server = Mcp_server
659
+
module Hook = Hook
660
+
module Message = Message
661
+
module Response = Response
662
+
module Model = Model
663
+
module Permission_mode = Permission_mode
664
+
module Server_info = Server_info
665
+
module Err = Err
666
+
```
667
+
668
+
---
669
+
670
+
## Error Handling
671
+
672
+
```ocaml
673
+
(* err.mli *)
674
+
675
+
(** Structured error types. *)
676
+
677
+
type t =
678
+
| Cli_not_found of string
679
+
| Process_error of { exit_code : int; message : string }
680
+
| Protocol_error of { message : string; raw : string option }
681
+
| Timeout of { operation : string }
682
+
| Permission_denied of { tool : string; reason : string }
683
+
| Hook_error of { hook : string; error : string }
684
+
| Mcp_error of { server : string; method_ : string; error : string }
685
+
686
+
exception E of t
687
+
688
+
val to_string : t -> string
689
+
val raise_cli_not_found : string -> 'a
690
+
val raise_process_error : exit_code:int -> message:string -> 'a
691
+
val raise_protocol_error : message:string -> ?raw:string -> unit -> 'a
692
+
val raise_timeout : operation:string -> 'a
693
+
```
694
+
695
+
---
696
+
697
+
## Internal Architecture
698
+
699
+
### Process Management
700
+
701
+
The internal process module spawns Claude CLI and manages bidirectional communication:
702
+
703
+
```ocaml
704
+
(* internal/process.ml *)
705
+
706
+
type t = {
707
+
proc : Eio.Process.t;
708
+
stdin : Eio.Flow.sink;
709
+
stdout : Eio.Flow.source;
710
+
stderr : Eio.Flow.source;
711
+
}
712
+
713
+
val spawn :
714
+
sw:Eio.Switch.t ->
715
+
process_mgr:_ Eio.Process.mgr ->
716
+
?cli_path:string ->
717
+
?cwd:Eio.Fs.dir_ty Eio.Path.t ->
718
+
args:string list ->
719
+
unit ->
720
+
t
721
+
722
+
val send_line : t -> string -> unit
723
+
val read_line : t -> string option
724
+
val close : t -> unit
725
+
```
726
+
727
+
### Protocol Handling
728
+
729
+
The protocol module handles JSON wire format:
730
+
731
+
```ocaml
732
+
(* internal/protocol.ml *)
733
+
734
+
type incoming =
735
+
| Message of Message.t
736
+
| Control_request of {
737
+
request_id : string;
738
+
request : control_request;
739
+
}
740
+
| Control_response of {
741
+
request_id : string;
742
+
response : control_response;
743
+
}
744
+
745
+
and control_request =
746
+
| Permission_request of { tool_name : string; input : Jsont.json }
747
+
| Hook_callback of { callback_id : string; input : Jsont.json }
748
+
| Mcp_request of { server : string; message : Jsont.json }
749
+
750
+
and control_response =
751
+
| Success of { response : Jsont.json option }
752
+
| Error of { message : string }
753
+
754
+
type outgoing =
755
+
| User_message of Message.User.t
756
+
| Control_request of { request : Request.t }
757
+
| Control_response of { request_id : string; response : Response.t }
758
+
759
+
val decode : string -> incoming
760
+
val encode : outgoing -> string
761
+
```
762
+
763
+
### MCP Handler
764
+
765
+
Routes MCP requests to appropriate in-process servers:
766
+
767
+
```ocaml
768
+
(* internal/mcp_handler.ml *)
769
+
770
+
type t
771
+
772
+
val create : servers:(string * Mcp_server.t) list -> t
773
+
774
+
val handle_request :
775
+
t ->
776
+
server:string ->
777
+
message:Jsont.json ->
778
+
Jsont.json
779
+
(** Handle MCP JSONRPC request and return response. *)
780
+
```
781
+
782
+
---
783
+
784
+
## Message Flow Diagrams
785
+
786
+
### Built-in Tool Execution (passthrough)
787
+
788
+
```
789
+
User SDK Client Claude CLI Claude
790
+
| | | |
791
+
|--query()------>| | |
792
+
| |--UserMsg------>| |
793
+
| | |--API call--->|
794
+
| | |<--tool_use---|
795
+
| | | (Read file) |
796
+
| | | |
797
+
| | | [CLI executes Read internally]
798
+
| | | |
799
+
| | |--tool_result>|
800
+
| | |<--text-------|
801
+
| |<--Response-----| |
802
+
|<--Response.Text| | |
803
+
```
804
+
805
+
### Custom MCP Tool Execution
806
+
807
+
```
808
+
User SDK Client Claude CLI Claude
809
+
| | | |
810
+
|--query()------>| | |
811
+
| |--UserMsg------>| |
812
+
| | |--API call--->|
813
+
| | |<--tool_use---|
814
+
| | | (mcp__x__y) |
815
+
| |<--mcp_request--| |
816
+
| | | |
817
+
| | [SDK routes to Mcp_server] |
818
+
| | | |
819
+
| |--mcp_response->| |
820
+
| | |--tool_result>|
821
+
| | |<--text-------|
822
+
| |<--Response-----| |
823
+
|<--Response.Text| | |
824
+
```
825
+
826
+
### Hook Interception
827
+
828
+
```
829
+
User SDK Client Claude CLI Claude
830
+
| | | |
831
+
|--query()------>| | |
832
+
| |--UserMsg------>| |
833
+
| | |--API call--->|
834
+
| | |<--tool_use---|
835
+
| | | (Bash) |
836
+
| |<--hook_callback| |
837
+
| | [PreToolUse] | |
838
+
| | | |
839
+
| | [SDK runs hook, returns Deny] |
840
+
| | | |
841
+
| |--hook_response>| (denied) |
842
+
| | |--error msg-->|
843
+
| | |<--text-------|
844
+
| |<--Response-----| |
845
+
|<--Response.Text| | |
846
+
```
847
+
848
+
---
849
+
850
+
## Migration from Current SDK
851
+
852
+
### Key Changes
853
+
854
+
1. **Remove explicit tool execution**
855
+
- Current: SDK receives tool_use, executes tool, returns result
856
+
- New: Built-in tools handled by CLI; only MCP tools executed by SDK
857
+
858
+
2. **Add MCP server support**
859
+
- New: `Tool.t`, `Mcp_server.t` for custom tool definition
860
+
861
+
3. **Simplify hooks**
862
+
- Current: Hooks can have complex tool execution logic
863
+
- New: Hooks intercept only; execution is separate
864
+
865
+
4. **Clean up Handler module**
866
+
- Current: Object-oriented handler class
867
+
- New: Functional response handling via `Seq.t`
868
+
869
+
### Compatibility Notes
870
+
871
+
- `Options.with_hooks` remains similar
872
+
- `Client.query/receive` API stays the same
873
+
- New: `Options.with_mcp_server` for custom tools
874
+
- Removed: Direct tool execution callbacks
875
+
876
+
---
877
+
878
+
## Example: Complete Application
879
+
880
+
```ocaml
881
+
open Eio.Std
882
+
883
+
(* Define custom tools *)
884
+
let calculator_add = Claude.Tool.create
885
+
~name:"add"
886
+
~description:"Add two numbers"
887
+
~input_schema:(`O [
888
+
"a", `O ["type", `String "number"];
889
+
"b", `O ["type", `String "number"];
890
+
])
891
+
~handler:(fun args ->
892
+
match Jsont.(find_float "a" args, find_float "b" args) with
893
+
| Some a, Some b -> Ok (`String (Printf.sprintf "%.2f" (a +. b)))
894
+
| _ -> Error "Missing a or b parameter")
895
+
896
+
let calculator_multiply = Claude.Tool.create
897
+
~name:"multiply"
898
+
~description:"Multiply two numbers"
899
+
~input_schema:(`O [
900
+
"a", `O ["type", `String "number"];
901
+
"b", `O ["type", `String "number"];
902
+
])
903
+
~handler:(fun args ->
904
+
match Jsont.(find_float "a" args, find_float "b" args) with
905
+
| Some a, Some b -> Ok (`String (Printf.sprintf "%.2f" (a *. b)))
906
+
| _ -> Error "Missing a or b parameter")
907
+
908
+
(* Create MCP server *)
909
+
let calculator_server = Claude.Mcp_server.create
910
+
~name:"calculator"
911
+
~version:"1.0.0"
912
+
~tools:[calculator_add; calculator_multiply]
913
+
()
914
+
915
+
(* Define hook to block dangerous commands *)
916
+
let block_dangerous_bash input =
917
+
if input.Claude.Hook.PreToolUse.tool_name = "Bash" then
918
+
match Claude.Tool_input.string input.tool_input "command" with
919
+
| Some cmd when String.is_substring cmd ~substring:"rm -rf" ->
920
+
Claude.Hook.PreToolUse.deny ~reason:"Dangerous command blocked"
921
+
| _ -> Claude.Hook.PreToolUse.allow ()
922
+
else Claude.Hook.PreToolUse.allow ()
923
+
924
+
let hooks = Claude.Hook.Config.empty
925
+
|> Claude.Hook.Config.on_pre_tool_use ~pattern:"Bash" block_dangerous_bash
926
+
927
+
(* Main application *)
928
+
let () = Eio_main.run @@ fun env ->
929
+
Switch.run @@ fun sw ->
930
+
let process_mgr = Eio.Stdenv.process_mgr env in
931
+
let clock = Eio.Stdenv.clock env in
932
+
933
+
let options = Claude.Options.default
934
+
|> Claude.Options.with_model Claude.Model.opus
935
+
|> Claude.Options.with_mcp_server ~name:"calc" calculator_server
936
+
|> Claude.Options.with_allowed_tools [
937
+
"mcp__calc__add";
938
+
"mcp__calc__multiply";
939
+
"Read";
940
+
"Bash";
941
+
]
942
+
|> Claude.Options.with_hooks hooks
943
+
|> Claude.Options.with_max_budget_usd 0.50
944
+
in
945
+
946
+
let client = Claude.Client.create ~sw ~process_mgr ~clock ~options () in
947
+
948
+
(* Multi-turn conversation *)
949
+
Claude.Client.query client "What is 23 + 45?";
950
+
Claude.Client.receive client |> Seq.iter (function
951
+
| Claude.Response.Text t ->
952
+
Printf.printf "Claude: %s\n" (Claude.Response.Text.content t)
953
+
| Claude.Response.Tool_use tu ->
954
+
Printf.printf "[Using tool: %s]\n" (Claude.Response.Tool_use.name tu)
955
+
| Claude.Response.Complete c ->
956
+
Printf.printf "[Cost: $%.4f]\n"
957
+
(Option.value ~default:0.0 (Claude.Response.Complete.total_cost_usd c))
958
+
| _ -> ());
959
+
960
+
Claude.Client.query client "Now multiply that result by 2";
961
+
Claude.Client.receive_all client |> ignore
962
+
```
963
+
964
+
---
965
+
966
+
## Implementation Priority
967
+
968
+
1. **Phase 1: Core Types**
969
+
- `Tool.t`, `Mcp_server.t`
970
+
- Updated `Options.t` with MCP support
971
+
- `Permission_mode.t`, `Model.t`
972
+
973
+
2. **Phase 2: Internal MCP Routing**
974
+
- `internal/mcp_handler.ml`
975
+
- Protocol updates for MCP messages
976
+
- Remove built-in tool execution from client
977
+
978
+
3. **Phase 3: Hook Simplification**
979
+
- Update `Hook` module to intercept-only model
980
+
- Remove tool execution from hook callbacks
981
+
982
+
4. **Phase 4: API Polish**
983
+
- Simple `query` function
984
+
- Documentation and examples
985
+
- Error handling improvements
986
+
987
+
5. **Phase 5: Testing & Migration**
988
+
- Comprehensive tests
989
+
- Migration guide
990
+
- Deprecation of old patterns
+15
LICENSE.md
+15
LICENSE.md
···
1
+
ISC License
2
+
3
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>
4
+
5
+
Permission to use, copy, modify, and distribute this software for any
6
+
purpose with or without fee is hereby granted, provided that the above
7
+
copyright notice and this permission notice appear in all copies.
8
+
9
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10
+
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11
+
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12
+
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13
+
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14
+
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15
+
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+82
README.md
+82
README.md
···
1
+
# claude -- OCaml client library for Claude Code
2
+
3
+
An Eio-based OCaml library for interacting with the Claude Code CLI using
4
+
JSON streaming.
5
+
6
+
## Overview
7
+
8
+
This library wraps the Claude Code CLI in a typed OCaml interface with
9
+
bidirectional JSON streaming. It handles the full conversation protocol:
10
+
message streaming, permission callbacks, tool execution hooks, and
11
+
mid-conversation control.
12
+
13
+
## Features
14
+
15
+
- **Message streaming** -- Lazy `Seq.t`-based response streaming
16
+
- **Permission control** -- Custom callbacks for tool usage authorization
17
+
- **Hooks** -- Intercept and modify tool execution
18
+
- **Tool definitions** -- Register custom tools with JSON Schema input
19
+
- **MCP servers** -- Integrate Model Context Protocol servers
20
+
- **Structured output** -- Request JSON responses matching a schema
21
+
- **Dynamic control** -- Change model, permissions, or settings mid-conversation
22
+
- **Server introspection** -- Query available tools, models, and capabilities
23
+
24
+
## Installation
25
+
26
+
```
27
+
opam install claude
28
+
```
29
+
30
+
## Usage
31
+
32
+
### Basic query
33
+
34
+
```ocaml
35
+
Eio_main.run @@ fun env ->
36
+
Eio.Switch.run @@ fun sw ->
37
+
let process_mgr = Eio.Stdenv.process_mgr env in
38
+
let clock = Eio.Stdenv.clock env in
39
+
let client = Client.v ~sw ~process_mgr ~clock () in
40
+
Client.query client "What is 2+2?";
41
+
let messages = Client.receive_all client in
42
+
List.iter
43
+
(function
44
+
| Message.Assistant msg ->
45
+
Printf.printf "Claude: %s\n" (Message.Assistant.text msg)
46
+
| _ -> ())
47
+
messages
48
+
```
49
+
50
+
### Streaming responses
51
+
52
+
```ocaml
53
+
let client = Client.v ~sw ~process_mgr ~clock () in
54
+
Client.query client "Explain OCaml modules";
55
+
Client.receive client |> Seq.iter (fun msg ->
56
+
match msg with
57
+
| Message.Assistant a -> print_string (Message.Assistant.text a)
58
+
| _ -> ())
59
+
```
60
+
61
+
### With custom handler
62
+
63
+
```ocaml
64
+
let handler = Handler.default
65
+
~on_text:(fun _client text -> print_string text)
66
+
~on_tool_use:(fun _client tool ->
67
+
Fmt.pr "Tool: %s\n" (Response.Tool_use.name tool))
68
+
()
69
+
in
70
+
let client = Client.v ~sw ~process_mgr ~clock () in
71
+
Client.run client ~handler "Summarize this project"
72
+
```
73
+
74
+
## Requirements
75
+
76
+
- OCaml >= 5.1
77
+
- Eio, Jsont, Cmdliner, Bytesrw
78
+
- Claude Code CLI installed and configured
79
+
80
+
## Licence
81
+
82
+
ISC
+42
claude.opam
+42
claude.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "OCaml client library for Claude Code"
4
+
description:
5
+
"An Eio-based OCaml library for interacting with the Claude CLI using JSON streaming"
6
+
maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
7
+
authors: ["Anil Madhavapeddy"]
8
+
license: "ISC"
9
+
tags: ["org:blacksun" "cli"]
10
+
homepage: "https://tangled.org/anil.recoil.org/ocaml-claudeio"
11
+
bug-reports: "https://tangled.org/anil.recoil.org/ocaml-claudeio/issues"
12
+
depends: [
13
+
"dune" {>= "3.21"}
14
+
"ocaml" {>= "5.1.0"}
15
+
"eio"
16
+
"eio_main"
17
+
"fmt"
18
+
"logs"
19
+
"cmdliner"
20
+
"bytesrw"
21
+
"jsont" {>= "0.2.0"}
22
+
"odoc" {with-doc}
23
+
"alcotest" {with-test & >= "1.7.0"}
24
+
]
25
+
build: [
26
+
["dune" "subst"] {dev}
27
+
[
28
+
"dune"
29
+
"build"
30
+
"-p"
31
+
name
32
+
"-j"
33
+
jobs
34
+
"@install"
35
+
"@runtest" {with-test}
36
+
"@doc" {with-doc}
37
+
]
38
+
]
39
+
dev-repo: "git+https://tangled.org/anil.recoil.org/ocaml-claudeio"
40
+
x-maintenance-intent: ["(latest)"]
41
+
x-quality-build: "2026-04-15"
42
+
x-quality-test: "2026-04-15"
+5
dune
+5
dune
+26
dune-project
+26
dune-project
···
1
+
(lang dune 3.21)
2
+
(name claude)
3
+
4
+
(generate_opam_files true)
5
+
6
+
(license ISC)
7
+
(authors "Anil Madhavapeddy")
8
+
(maintainers "Anil Madhavapeddy <anil@recoil.org>")
9
+
(source (tangled anil.recoil.org/ocaml-claudeio))
10
+
11
+
(package
12
+
(name claude)
13
+
(synopsis "OCaml client library for Claude Code")
14
+
(tags (org:blacksun cli))
15
+
(description "An Eio-based OCaml library for interacting with the Claude CLI using JSON streaming")
16
+
(depends
17
+
(ocaml (>= 5.1.0))
18
+
eio
19
+
eio_main
20
+
fmt
21
+
logs
22
+
cmdliner
23
+
bytesrw
24
+
(jsont (>= 0.2.0))
25
+
(odoc :with-doc)
26
+
(alcotest (and :with-test (>= 1.7.0)))))
+35
examples/README.md
+35
examples/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
examples/TEST.md
+112
examples/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.
+159
examples/advanced_config_demo.ml
+159
examples/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.Model.of_string "claude-haiku-4")
32
+
(* Fast fallback *)
33
+
|> Options.with_model (Claude.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.Model.of_string "claude-sonnet-4-5")
44
+
|> Options.with_fallback_model (Claude.Model.of_string "claude-sonnet-3-5")
45
+
|> Options.with_max_budget_usd 10.0 (* $10 limit *)
46
+
|> Options.with_max_buffer_size 5_000_000 (* 5MB buffer for large outputs *)
47
+
48
+
(* Example 3: Development Configuration
49
+
50
+
Development with user settings enabled but with cost controls.
51
+
*)
52
+
let dev_config () =
53
+
Options.default
54
+
(* Note: Settings are loaded by default from user/project/local files *)
55
+
|> Options.with_max_budget_usd 1.0 (* $1 limit for dev testing *)
56
+
|> Options.with_fallback_model (Claude.Model.of_string "claude-haiku-4")
57
+
58
+
(* Example 4: Isolated Test Configuration
59
+
60
+
For automated testing with no external settings and strict limits.
61
+
*)
62
+
let test_config () =
63
+
Options.default |> Options.with_no_settings
64
+
|> Options.with_max_budget_usd 0.10 (* 10 cent limit per test *)
65
+
|> Options.with_model (Claude.Model.of_string "claude-haiku-4")
66
+
(* Fast, cheap model *)
67
+
|> Options.with_permission_mode Permissions.Mode.Bypass_permissions
68
+
|> Options.with_max_buffer_size 1_000_000 (* 1MB buffer *)
69
+
70
+
(* Example 5: Custom Buffer Size Demo
71
+
72
+
For applications that need to handle very large outputs.
73
+
*)
74
+
let _large_output_config () =
75
+
Options.default
76
+
|> Options.with_max_buffer_size 10_000_000 (* 10MB buffer *)
77
+
|> Options.with_model (Claude.Model.of_string "claude-sonnet-4-5")
78
+
79
+
(* Helper to run a query with a specific configuration *)
80
+
let run_query ~sw process_mgr clock config prompt =
81
+
print_endline "\n=== Configuration ===";
82
+
(match Options.max_budget_usd config with
83
+
| Some budget -> Fmt.pr "Budget limit: $%.2f\n" budget
84
+
| None -> print_endline "Budget limit: None");
85
+
(match Options.fallback_model config with
86
+
| Some model -> Fmt.pr "Fallback model: %s\n" (Claude.Model.to_string model)
87
+
| None -> print_endline "Fallback model: None");
88
+
(* Settings configuration display removed - API doesn't expose setting_sources *)
89
+
print_endline "Settings: Default (user/project/local files)";
90
+
(match Options.max_buffer_size config with
91
+
| Some size -> Fmt.pr "Buffer size: %d bytes\n" size
92
+
| None -> print_endline "Buffer size: Default (1MB)");
93
+
94
+
print_endline "\n=== Running Query ===";
95
+
let client = Client.v ~options:config ~sw ~process_mgr ~clock () in
96
+
Client.query client prompt;
97
+
let responses = Client.receive client in
98
+
99
+
Seq.iter
100
+
(function
101
+
| Response.Text text ->
102
+
Fmt.pr "Response: %s\n" (Response.Text.content text)
103
+
| Response.Complete result ->
104
+
Fmt.pr "\n=== Session Complete ===\n";
105
+
Fmt.pr "Duration: %dms\n" (Response.Complete.duration_ms result);
106
+
(match Response.Complete.total_cost_usd result with
107
+
| Some cost -> Fmt.pr "Cost: $%.4f\n" cost
108
+
| None -> ());
109
+
Fmt.pr "Turns: %d\n" (Response.Complete.num_turns result)
110
+
| _ -> ())
111
+
responses
112
+
113
+
let main () =
114
+
log_setup ();
115
+
116
+
Eio_main.run @@ fun env ->
117
+
Switch.run @@ fun sw ->
118
+
let process_mgr = Eio.Stdenv.process_mgr env in
119
+
let clock = Eio.Stdenv.clock env in
120
+
121
+
print_endline "==============================================";
122
+
print_endline "Claude SDK - Advanced Configuration Examples";
123
+
print_endline "==============================================";
124
+
125
+
(* Example: CI/CD isolated environment *)
126
+
print_endline "\n\n### Example 1: CI/CD Configuration ###";
127
+
print_endline "Purpose: Isolated, reproducible environment for CI/CD";
128
+
let config = ci_cd_config () in
129
+
run_query ~sw process_mgr clock config "What is 2+2? Answer in one sentence.";
130
+
131
+
(* Example: Production with fallback *)
132
+
print_endline "\n\n### Example 2: Production Configuration ###";
133
+
print_endline "Purpose: Production with cost controls and fallback";
134
+
let config = production_config () in
135
+
run_query ~sw process_mgr clock config "Explain OCaml in one sentence.";
136
+
137
+
(* Example: Development with settings *)
138
+
print_endline "\n\n### Example 3: Development Configuration ###";
139
+
print_endline "Purpose: Development with user/project settings";
140
+
let config = dev_config () in
141
+
run_query ~sw process_mgr clock config
142
+
"What is functional programming? One sentence.";
143
+
144
+
(* Example: Test configuration *)
145
+
print_endline "\n\n### Example 4: Test Configuration ###";
146
+
print_endline "Purpose: Automated testing with strict limits";
147
+
let config = test_config () in
148
+
run_query ~sw process_mgr clock config "Say 'test passed' in one word.";
149
+
150
+
print_endline "\n\n==============================================";
151
+
print_endline "All examples completed successfully!";
152
+
print_endline "=============================================="
153
+
154
+
let () =
155
+
try main ()
156
+
with e ->
157
+
Fmt.epr "Error: %s\n" (Printexc.to_string e);
158
+
Printexc.print_backtrace stderr;
159
+
exit 1
+139
examples/camel_jokes.ml
+139
examples/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.v ~options ~sw ~process_mgr:env#process_mgr ~clock:env#clock
58
+
()
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
examples/discovery_demo.ml
+111
examples/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.Model.of_string "sonnet")
45
+
in
46
+
let client =
47
+
Claude.Client.v ~options ~sw ~process_mgr:env#process_mgr ~clock:env#clock
48
+
()
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 -> Fmt.str " (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))
+100
examples/dune
+100
examples/dune
···
1
+
(library
2
+
(name json_utils)
3
+
(modules json_utils)
4
+
(libraries jsont jsont.bytesrw))
5
+
6
+
(executable
7
+
(name camel_jokes)
8
+
(modules camel_jokes)
9
+
(libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
10
+
11
+
(executable
12
+
(name permission_demo)
13
+
(modules permission_demo)
14
+
(libraries
15
+
json_utils
16
+
claude
17
+
eio_main
18
+
cmdliner
19
+
logs
20
+
logs.fmt
21
+
fmt.tty
22
+
fmt.cli
23
+
logs.cli))
24
+
25
+
(executable
26
+
(name discovery_demo)
27
+
(modules discovery_demo)
28
+
(libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
29
+
30
+
(executable
31
+
(name simulated_permissions)
32
+
(modules simulated_permissions)
33
+
(libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
34
+
35
+
(executable
36
+
(name permissions_demo)
37
+
(modules permissions_demo)
38
+
(libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
39
+
40
+
(executable
41
+
(name simple_permission_test)
42
+
(modules simple_permission_test)
43
+
(libraries
44
+
json_utils
45
+
claude
46
+
eio_main
47
+
cmdliner
48
+
logs
49
+
logs.fmt
50
+
fmt.tty
51
+
fmt.cli
52
+
logs.cli))
53
+
54
+
(executable
55
+
(name hooks_example)
56
+
(modules hooks_example)
57
+
(libraries
58
+
json_utils
59
+
claude
60
+
eio_main
61
+
cmdliner
62
+
logs
63
+
logs.fmt
64
+
fmt.tty
65
+
fmt.cli
66
+
logs.cli))
67
+
68
+
(executable
69
+
(name dynamic_control_demo)
70
+
(modules dynamic_control_demo)
71
+
(libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
72
+
73
+
(executable
74
+
(name advanced_config_demo)
75
+
(modules advanced_config_demo)
76
+
(libraries claude eio_main logs logs.fmt fmt.tty))
77
+
78
+
(executable
79
+
(name structured_output_demo)
80
+
(modules structured_output_demo)
81
+
(flags
82
+
(:standard -w -33))
83
+
(libraries json_utils claude eio_main logs logs.fmt fmt.tty))
84
+
85
+
(executable
86
+
(name structured_output_simple)
87
+
(modules structured_output_simple)
88
+
(flags
89
+
(:standard -w -33))
90
+
(libraries json_utils claude eio_main logs logs.fmt fmt.tty))
91
+
92
+
(executable
93
+
(name incoming_demo)
94
+
(modules incoming_demo)
95
+
(libraries claude jsont.bytesrw fmt))
96
+
97
+
(executable
98
+
(name structured_error_demo)
99
+
(modules structured_error_demo)
100
+
(libraries claude eio_main jsont.bytesrw fmt))
+92
examples/dynamic_control_demo.ml
+92
examples/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 print_server_info client =
13
+
try
14
+
let info = Client.server_info client in
15
+
traceln "Server version: %s" (Claude.Server_info.version info);
16
+
traceln "Capabilities: [%s]"
17
+
(String.concat ", " (Claude.Server_info.capabilities info));
18
+
traceln "Commands: [%s]"
19
+
(String.concat ", " (Claude.Server_info.commands info));
20
+
traceln "Output styles: [%s]"
21
+
(String.concat ", " (Claude.Server_info.output_styles info))
22
+
with
23
+
| Failure msg -> traceln "Failed to get server info: %s" msg
24
+
| exn -> traceln "Error getting server info: %s" (Printexc.to_string exn)
25
+
26
+
let run env =
27
+
Switch.run @@ fun sw ->
28
+
let process_mgr = Eio.Stdenv.process_mgr env in
29
+
let clock = Eio.Stdenv.clock env in
30
+
31
+
(* Create client with default options *)
32
+
let options = Options.default in
33
+
let client = Client.v ~options ~sw ~process_mgr ~clock () in
34
+
35
+
traceln "=== Dynamic Control Demo ===\n";
36
+
37
+
(* First query with default model *)
38
+
traceln "1. Initial query with default model";
39
+
Client.query client "What model are you?";
40
+
41
+
(* Consume initial responses *)
42
+
let responses = Client.receive_all client in
43
+
List.iter
44
+
(function
45
+
| Response.Text text ->
46
+
traceln "Assistant: %s" (Response.Text.content text)
47
+
| _ -> ())
48
+
responses;
49
+
50
+
traceln "\n2. Getting server info...";
51
+
print_server_info client;
52
+
53
+
traceln "\n3. Switching to a different model (if available)...";
54
+
(try
55
+
Client.set_model client (Model.of_string "claude-sonnet-4");
56
+
traceln "Model switched successfully";
57
+
58
+
(* Query with new model *)
59
+
Client.query client "Confirm your model again please.";
60
+
let responses = Client.receive_all client in
61
+
List.iter
62
+
(function
63
+
| Response.Text text ->
64
+
traceln "Assistant (new model): %s" (Response.Text.content text)
65
+
| _ -> ())
66
+
responses
67
+
with
68
+
| Failure msg -> traceln "Failed to switch model: %s" msg
69
+
| exn -> traceln "Error switching model: %s" (Printexc.to_string exn));
70
+
71
+
traceln "\n4. Changing permission mode...";
72
+
(try
73
+
Client.set_permission_mode client Permissions.Mode.Accept_edits;
74
+
traceln "Permission mode changed to Accept_edits"
75
+
with
76
+
| Failure msg -> traceln "Failed to change permission mode: %s" msg
77
+
| exn -> traceln "Error changing permission mode: %s" (Printexc.to_string exn));
78
+
79
+
traceln "\n=== Demo Complete ===";
80
+
()
81
+
82
+
let () =
83
+
Eio_main.run @@ fun env ->
84
+
try run env with
85
+
| Transport.CLI_not_found msg ->
86
+
traceln "Error: %s" msg;
87
+
traceln "Make sure the 'claude' CLI is installed and authenticated.";
88
+
exit 1
89
+
| exn ->
90
+
traceln "Unexpected error: %s" (Printexc.to_string exn);
91
+
Printexc.print_backtrace stderr;
92
+
exit 1
+123
examples/hooks_example.ml
+123
examples/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.Pre_tool_use.tool_name = "Bash" then
15
+
match
16
+
Claude.Tool_input.string input.Claude.Hooks.Pre_tool_use.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.Pre_tool_use.deny
23
+
~reason:"Command contains dangerous 'rm -rf' pattern" ()
24
+
end
25
+
else Claude.Hooks.Pre_tool_use.continue ()
26
+
| _ -> Claude.Hooks.Pre_tool_use.continue ()
27
+
else Claude.Hooks.Pre_tool_use.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.Pre_tool_use.tool_name);
33
+
Claude.Hooks.Pre_tool_use.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.v ~options ~sw ~process_mgr:env#process_mgr ~clock:env#clock
54
+
()
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))
+89
examples/incoming_demo.ml
+89
examples/incoming_demo.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Test the Incoming message codec *)
7
+
8
+
let test_decode_user_message () =
9
+
let json_str = {|{"type":"user","content":"Hello"}|} in
10
+
match Jsont_bytesrw.decode_string' Claude.Incoming.jsont json_str with
11
+
| Ok (Claude.Incoming.Message (Claude.Message.User _)) ->
12
+
print_endline "✓ Decoded user message successfully"
13
+
| Ok _ -> print_endline "✗ Wrong message type decoded"
14
+
| Error err ->
15
+
Fmt.pr "✗ Failed to decode user message: %s\n" (Jsont.Error.to_string err)
16
+
17
+
let test_decode_assistant_message () =
18
+
let json_str =
19
+
{|{"type":"assistant","model":"claude-sonnet-4","content":[{"type":"text","text":"Hi"}]}|}
20
+
in
21
+
match Jsont_bytesrw.decode_string' Claude.Incoming.jsont json_str with
22
+
| Ok (Claude.Incoming.Message (Claude.Message.Assistant _)) ->
23
+
print_endline "✓ Decoded assistant message successfully"
24
+
| Ok _ -> print_endline "✗ Wrong message type decoded"
25
+
| Error err ->
26
+
Fmt.pr "✗ Failed to decode assistant message: %s\n"
27
+
(Jsont.Error.to_string err)
28
+
29
+
let test_decode_system_message () =
30
+
let json_str =
31
+
{|{"type":"system","subtype":"init","data":{"session_id":"test-123"}}|}
32
+
in
33
+
match Jsont_bytesrw.decode_string' Claude.Incoming.jsont json_str with
34
+
| Ok (Claude.Incoming.Message (Claude.Message.System _)) ->
35
+
print_endline "✓ Decoded system message successfully"
36
+
| Ok _ -> print_endline "✗ Wrong message type decoded"
37
+
| Error err ->
38
+
Fmt.pr "✗ Failed to decode system message: %s\n"
39
+
(Jsont.Error.to_string err)
40
+
41
+
let test_decode_control_response () =
42
+
let json_str =
43
+
{|{"type":"control_response","response":{"subtype":"success","request_id":"test-req-1"}}|}
44
+
in
45
+
match Jsont_bytesrw.decode_string' Claude.Incoming.jsont json_str with
46
+
| Ok (Claude.Incoming.Control_response resp) -> (
47
+
match resp.response with
48
+
| Claude.Control.Response.Success s ->
49
+
if s.request_id = "test-req-1" then
50
+
print_endline "✓ Decoded control response successfully"
51
+
else Fmt.pr "✗ Wrong request_id: %s\n" s.request_id
52
+
| Claude.Control.Response.Error _ ->
53
+
print_endline "✗ Got error response instead of success")
54
+
| Ok _ -> print_endline "✗ Wrong message type decoded"
55
+
| Error err ->
56
+
Fmt.pr "✗ Failed to decode control response: %s\n"
57
+
(Jsont.Error.to_string err)
58
+
59
+
let test_decode_control_response_error () =
60
+
let json_str =
61
+
{|{"type":"control_response","response":{"subtype":"error","request_id":"test-req-2","error":{"code":-32603,"message":"Something went wrong"}}}|}
62
+
in
63
+
match Jsont_bytesrw.decode_string' Claude.Incoming.jsont json_str with
64
+
| Ok (Claude.Incoming.Control_response resp) -> (
65
+
match resp.response with
66
+
| Claude.Control.Response.Error e ->
67
+
if
68
+
e.request_id = "test-req-2"
69
+
&& e.error.code = -32603
70
+
&& e.error.message = "Something went wrong"
71
+
then print_endline "✓ Decoded control error response successfully"
72
+
else Fmt.pr "✗ Wrong error content\n"
73
+
| Claude.Control.Response.Success _ ->
74
+
print_endline "✗ Got success response instead of error")
75
+
| Ok _ -> print_endline "✗ Wrong message type decoded"
76
+
| Error err ->
77
+
Fmt.pr "✗ Failed to decode control error response: %s\n"
78
+
(Jsont.Error.to_string err)
79
+
80
+
let () =
81
+
print_endline "Testing Incoming message codec...";
82
+
print_endline "";
83
+
test_decode_user_message ();
84
+
test_decode_assistant_message ();
85
+
test_decode_system_message ();
86
+
test_decode_control_response ();
87
+
test_decode_control_response_error ();
88
+
print_endline "";
89
+
print_endline "All tests completed!"
+31
examples/json_utils.ml
+31
examples/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 find (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 string json key = find Jsont.string json key
24
+
let int json key = find Jsont.int json key
25
+
let bool json key = find Jsont.bool json key
26
+
let array json key = find (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
+24
examples/json_utils.mli
+24
examples/json_utils.mli
···
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 examples using jsont codecs. *)
7
+
8
+
val to_string : ?minify:bool -> Jsont.json -> string
9
+
(** Encode JSON to string. *)
10
+
11
+
val string : Jsont.json -> string -> string option
12
+
(** [string json key] extracts a string field. *)
13
+
14
+
val int : Jsont.json -> string -> int option
15
+
(** [int json key] extracts an integer field. *)
16
+
17
+
val bool : Jsont.json -> string -> bool option
18
+
(** [bool json key] extracts a boolean field. *)
19
+
20
+
val array : Jsont.json -> string -> Jsont.json list option
21
+
(** [array json key] extracts an array field. *)
22
+
23
+
val as_string : Jsont.json -> string option
24
+
(** [as_string json] decodes JSON as a string value. *)
+243
examples/permission_demo.ml
+243
examples/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 String_set = Set.Make (String)
16
+
17
+
let tools = ref String_set.empty
18
+
19
+
let grant tool_name =
20
+
tools := String_set.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 = String_set.mem tool_name !tools
27
+
28
+
let list () =
29
+
if String_set.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
+
(String_set.elements !tools |> String.concat ", "))
35
+
end
36
+
37
+
(* Interactive permission callback *)
38
+
let log_tool_input tool_name input_json =
39
+
try
40
+
match tool_name with
41
+
| "Read" -> (
42
+
match Json_utils.string input_json "file_path" with
43
+
| Some file_path -> Log.app (fun m -> m "File: %s" file_path)
44
+
| None -> ())
45
+
| "Bash" -> (
46
+
match Json_utils.string input_json "command" with
47
+
| Some command -> Log.app (fun m -> m "Command: %s" command)
48
+
| None -> ())
49
+
| "Write" | "Edit" -> (
50
+
match Json_utils.string input_json "file_path" with
51
+
| Some file_path -> Log.app (fun m -> m "File: %s" file_path)
52
+
| None -> ())
53
+
| "Glob" -> (
54
+
match Json_utils.string input_json "pattern" with
55
+
| Some pattern -> (
56
+
Log.app (fun m -> m "Pattern: %s" pattern);
57
+
match Json_utils.string input_json "path" with
58
+
| Some path -> Log.app (fun m -> m "Path: %s" path)
59
+
| None -> Log.app (fun m -> m "Path: (current directory)"))
60
+
| None -> ())
61
+
| "Grep" -> (
62
+
match Json_utils.string input_json "pattern" with
63
+
| Some pattern -> (
64
+
Log.app (fun m -> m "Pattern: %s" pattern);
65
+
match Json_utils.string input_json "path" with
66
+
| Some path -> Log.app (fun m -> m "Path: %s" path)
67
+
| None -> Log.app (fun m -> m "Path: (current directory)"))
68
+
| None -> ())
69
+
| _ -> Log.app (fun m -> m "Input: %s" (Json_utils.to_string input_json))
70
+
with exn ->
71
+
Log.info (fun m ->
72
+
m "Failed to parse input details: %s" (Printexc.to_string exn))
73
+
74
+
let prompt_user tool_name =
75
+
let open Claude.Permissions in
76
+
Fmt.pr "Allow? [y/N/always]: %!";
77
+
let tty = open_in "/dev/tty" in
78
+
let response = input_line tty |> String.lowercase_ascii in
79
+
close_in tty;
80
+
match response with
81
+
| "y" | "yes" ->
82
+
Log.app (fun m -> m "→ Allowed (this time only)");
83
+
Log.info (fun m -> m "User approved %s for this request only" tool_name);
84
+
Decision.allow ()
85
+
| "a" | "always" ->
86
+
Granted.grant tool_name;
87
+
Log.info (fun m -> m "User granted permanent permission for %s" tool_name);
88
+
Decision.allow ()
89
+
| _ ->
90
+
Granted.deny tool_name;
91
+
Log.info (fun m -> m "User denied permission for %s" tool_name);
92
+
Decision.deny
93
+
~message:(Fmt.str "User denied access to %s" tool_name)
94
+
~interrupt:false
95
+
96
+
let interactive_permission_callback ctx =
97
+
let open Claude.Permissions in
98
+
let tool_name = ctx.tool_name in
99
+
let input = ctx.input in
100
+
101
+
Log.info (fun m -> m "🔔 Permission callback invoked for tool: %s" tool_name);
102
+
Log.app (fun m -> m "\n🔐 PERMISSION REQUEST 🔐");
103
+
Log.app (fun m -> m "Tool: %s" tool_name);
104
+
105
+
(* Log the full input for debugging *)
106
+
let input_json = Claude.Tool_input.to_json input in
107
+
Log.info (fun m -> m "Full input JSON: %s" (Json_utils.to_string input_json));
108
+
109
+
(* Show input details *)
110
+
log_tool_input tool_name input_json;
111
+
112
+
(* Check if already granted *)
113
+
if Granted.is_granted tool_name then begin
114
+
Log.app (fun m -> m "→ Auto-approved (previously granted)");
115
+
Log.info (fun m -> m "Returning allow result for %s" tool_name);
116
+
Decision.allow ()
117
+
end
118
+
else prompt_user tool_name
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.v ~options ~sw ~process_mgr:env#process_mgr ~clock:env#clock
165
+
()
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
examples/permission_demo.py
+185
examples/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())
+90
examples/permissions_demo.ml
+90
examples/permissions_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 = Logs.Src.create "test_permissions" ~doc:"Permission callback test"
9
+
10
+
module Log = (val Logs.src_log src : Logs.LOG)
11
+
12
+
(* Simple auto-allow permission callback *)
13
+
let auto_allow_callback ctx =
14
+
Log.app (fun m ->
15
+
m "✅ Auto-allowing tool: %s" ctx.Claude.Permissions.tool_name);
16
+
Claude.Permissions.Decision.allow ()
17
+
18
+
let run_test ~sw ~env =
19
+
Log.app (fun m -> m "🧪 Testing Permission Callbacks");
20
+
Log.app (fun m -> m "================================");
21
+
22
+
(* Create options with custom permission callback *)
23
+
let options =
24
+
Claude.Options.default
25
+
|> Claude.Options.with_model (Claude.Model.of_string "sonnet")
26
+
|> Claude.Options.with_permission_callback auto_allow_callback
27
+
in
28
+
29
+
Log.app (fun m -> m "Creating client with permission callback...");
30
+
let client =
31
+
Claude.Client.v ~options ~sw ~process_mgr:env#process_mgr ~clock:env#clock
32
+
()
33
+
in
34
+
35
+
(* Simple query that will trigger tool use *)
36
+
Log.app (fun m -> m "\n📤 Sending test query...");
37
+
Claude.Client.query client "What is 2 + 2? Just give me the number.";
38
+
39
+
(* Process response *)
40
+
let messages = Claude.Client.receive_all client in
41
+
Log.app (fun m -> m "\n📨 Received %d messages" (List.length messages));
42
+
43
+
List.iter
44
+
(fun resp ->
45
+
match resp with
46
+
| Claude.Response.Text text ->
47
+
Log.app (fun m -> m "Claude: %s" (Claude.Response.Text.content text))
48
+
| Claude.Response.Tool_use t ->
49
+
Log.app (fun m ->
50
+
m "🔧 Tool use: %s" (Claude.Response.Tool_use.name t))
51
+
| Claude.Response.Complete result ->
52
+
Log.app (fun m -> m "✅ Success!");
53
+
Log.app (fun m ->
54
+
m "Duration: %dms" (Claude.Response.Complete.duration_ms result))
55
+
| Claude.Response.Error err ->
56
+
Log.err (fun m -> m "❌ Error: %s" (Claude.Response.Error.message err))
57
+
| _ -> ())
58
+
messages;
59
+
60
+
Log.app (fun m -> m "\n================================");
61
+
Log.app (fun m -> m "✨ Test complete!")
62
+
63
+
let main ~env = Switch.run @@ fun sw -> run_test ~sw ~env
64
+
65
+
(* Command-line interface *)
66
+
open Cmdliner
67
+
68
+
let main_term env =
69
+
let setup_log style_renderer level =
70
+
Fmt_tty.setup_std_outputs ?style_renderer ();
71
+
Logs.set_level level;
72
+
Logs.set_reporter (Logs_fmt.reporter ());
73
+
if level = None then Logs.set_level (Some Logs.App);
74
+
match level with
75
+
| Some Logs.Info | Some Logs.Debug ->
76
+
Logs.Src.set_level Claude.Client.src (Some Logs.Info)
77
+
| _ -> ()
78
+
in
79
+
let run style level =
80
+
setup_log style level;
81
+
main ~env
82
+
in
83
+
Term.(const run $ Fmt_cli.style_renderer () $ Logs_cli.level ())
84
+
85
+
let cmd env =
86
+
let doc = "Test permission callback functionality" in
87
+
let info = Cmd.info "test_permissions" ~version:"1.0" ~doc in
88
+
Cmd.v info (main_term env)
89
+
90
+
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
+3
examples/secret_data.txt
+3
examples/secret_data.txt
+142
examples/simple_permission_test.ml
+142
examples/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
+
(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 process_test_responses messages =
24
+
let tool_count = ref 0 in
25
+
let write_used = ref false in
26
+
27
+
List.iter
28
+
(fun resp ->
29
+
match resp with
30
+
| Claude.Response.Text text ->
31
+
let content = Claude.Response.Text.content text in
32
+
if String.length content > 0 then
33
+
Log.app (fun m -> m "\n💬 Claude: %s" content)
34
+
| Claude.Response.Tool_use t ->
35
+
incr tool_count;
36
+
let tool_name = Claude.Response.Tool_use.name t in
37
+
if tool_name = "Write" then write_used := true;
38
+
Log.app (fun m -> m "🔧 Tool use #%d: %s" !tool_count tool_name)
39
+
| Claude.Response.Tool_result r ->
40
+
let tool_use_id = Claude.Content_block.Tool_result.tool_use_id r in
41
+
let is_error =
42
+
Claude.Content_block.Tool_result.is_error r
43
+
|> Option.value ~default:false
44
+
in
45
+
if is_error then begin
46
+
Log.app (fun m -> m "\n⚠️ Tool result error for %s:" tool_use_id);
47
+
match Claude.Content_block.Tool_result.content r with
48
+
| Some json ->
49
+
let s =
50
+
match Jsont_bytesrw.encode_string' Jsont.json json with
51
+
| Ok str -> str
52
+
| Error _ -> "<encoding error>"
53
+
in
54
+
Log.app (fun m -> m " %s" s)
55
+
| None -> ()
56
+
end
57
+
| Claude.Response.Complete result ->
58
+
Log.app (fun m -> m "\n✅ Success!");
59
+
(match Claude.Response.Complete.total_cost_usd result with
60
+
| Some cost -> Log.app (fun m -> m "💰 Cost: $%.6f" cost)
61
+
| None -> ());
62
+
Log.app (fun m ->
63
+
m "⏱️ Duration: %dms"
64
+
(Claude.Response.Complete.duration_ms result))
65
+
| Claude.Response.Error err ->
66
+
Log.err (fun m ->
67
+
m "\n❌ Error: %s" (Claude.Response.Error.message err))
68
+
| _ -> ())
69
+
messages;
70
+
71
+
(!tool_count, !write_used)
72
+
73
+
let run_test ~sw ~env =
74
+
Log.app (fun m -> m "🧪 Testing Permission Callbacks (Auto-Allow Mode)");
75
+
Log.app (fun m -> m "====================================================");
76
+
77
+
(* Create options with permission callback *)
78
+
let options =
79
+
Claude.Options.default
80
+
|> Claude.Options.with_model (Claude.Model.of_string "sonnet")
81
+
|> Claude.Options.with_permission_callback auto_allow_callback
82
+
in
83
+
84
+
Log.app (fun m -> m "Creating client with permission callback...");
85
+
let client =
86
+
Claude.Client.v ~options ~sw ~process_mgr:env#process_mgr ~clock:env#clock
87
+
()
88
+
in
89
+
90
+
(* Query that should trigger Write tool *)
91
+
Log.app (fun m -> m "\n📤 Asking Claude to write a file...");
92
+
Claude.Client.query client
93
+
"Write a simple hello world message to /tmp/test_permission.txt";
94
+
95
+
(* Process response *)
96
+
let messages = Claude.Client.receive_all client in
97
+
Log.app (fun m -> m "\n📨 Received %d messages" (List.length messages));
98
+
99
+
let tool_count, write_used = process_test_responses messages in
100
+
101
+
Log.app (fun m -> m "\n====================================================");
102
+
Log.app (fun m -> m "📊 Test Results:");
103
+
Log.app (fun m -> m " Total tools used: %d" tool_count);
104
+
Log.app (fun m -> m " Write tool used: %b" write_used);
105
+
106
+
if write_used then
107
+
Log.app (fun m ->
108
+
m " ✅ Permission callback successfully intercepted Write tool!")
109
+
else Log.app (fun m -> m " ⚠️ Write tool was not used (unexpected)");
110
+
111
+
Log.app (fun m -> m "====================================================");
112
+
Log.app (fun m -> m "✨ Test complete!")
113
+
114
+
let main ~env = Switch.run @@ fun sw -> run_test ~sw ~env
115
+
116
+
(* Command-line interface *)
117
+
open Cmdliner
118
+
119
+
let main_term env =
120
+
let setup_log style_renderer level =
121
+
Fmt_tty.setup_std_outputs ?style_renderer ();
122
+
Logs.set_level level;
123
+
Logs.set_reporter (Logs_fmt.reporter ());
124
+
if level = None then Logs.set_level (Some Logs.App);
125
+
match level with
126
+
| Some Logs.Info | Some Logs.Debug ->
127
+
Logs.Src.set_level Claude.Client.src (Some Logs.Info);
128
+
Logs.Src.set_level Claude.Transport.src (Some Logs.Info)
129
+
| _ -> ()
130
+
in
131
+
let run style level =
132
+
setup_log style level;
133
+
main ~env
134
+
in
135
+
Term.(const run $ Fmt_cli.style_renderer () $ Logs_cli.level ())
136
+
137
+
let cmd env =
138
+
let doc = "Test permission callback with auto-allow" in
139
+
let info = Cmd.info "simple_permission_test" ~version:"1.0" ~doc in
140
+
Cmd.v info (main_term env)
141
+
142
+
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
+229
examples/simulated_permissions.ml
+229
examples/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 Permission_state = struct
14
+
module String_set = Set.Make (String)
15
+
16
+
let granted = ref String_set.empty
17
+
let denied = ref String_set.empty
18
+
19
+
let grant tool =
20
+
granted := String_set.add tool !granted;
21
+
denied := String_set.remove tool !denied
22
+
23
+
let deny tool =
24
+
denied := String_set.add tool !denied;
25
+
granted := String_set.remove tool !granted
26
+
27
+
let is_granted tool = String_set.mem tool !granted
28
+
let is_denied tool = String_set.mem tool !denied
29
+
30
+
let _reset () =
31
+
granted := String_set.empty;
32
+
denied := String_set.empty
33
+
34
+
let show () =
35
+
Log.app (fun m -> m "\n📊 Permission Status:");
36
+
if String_set.is_empty !granted && String_set.is_empty !denied then
37
+
Log.app (fun m -> m " No permissions configured")
38
+
else begin
39
+
if not (String_set.is_empty !granted) then
40
+
Log.app (fun m ->
41
+
m " ✅ Granted: %s"
42
+
(String_set.elements !granted |> String.concat ", "));
43
+
if not (String_set.is_empty !denied) then
44
+
Log.app (fun m ->
45
+
m " ❌ Denied: %s"
46
+
(String_set.elements !denied |> String.concat ", "))
47
+
end
48
+
end
49
+
50
+
(* Example permission callback *)
51
+
let example_permission_callback ctx =
52
+
let open Claude.Permissions in
53
+
let tool_name = ctx.tool_name in
54
+
55
+
Log.app (fun m -> m "\n🔐 Permission Request for: %s" tool_name);
56
+
57
+
(* Check current state *)
58
+
if Permission_state.is_granted tool_name then begin
59
+
Log.app (fun m -> m " → Auto-approved (previously granted)");
60
+
Decision.allow ()
61
+
end
62
+
else if Permission_state.is_denied tool_name then begin
63
+
Log.app (fun m -> m " → Auto-denied (previously denied)");
64
+
Decision.deny
65
+
~message:(Fmt.str "Tool %s is blocked by policy" tool_name)
66
+
~interrupt:false
67
+
end
68
+
else begin
69
+
(* Ask user *)
70
+
Fmt.pr " Allow %s? [y/n/always/never]: %!" tool_name;
71
+
match read_line () |> String.lowercase_ascii with
72
+
| "y" | "yes" ->
73
+
Log.app (fun m -> m " → Allowed (one time)");
74
+
Decision.allow ()
75
+
| "n" | "no" ->
76
+
Log.app (fun m -> m " → Denied (one time)");
77
+
Decision.deny
78
+
~message:(Fmt.str "User denied %s" tool_name)
79
+
~interrupt:false
80
+
| "a" | "always" ->
81
+
Permission_state.grant tool_name;
82
+
Log.app (fun m -> m " → Allowed (always)");
83
+
Decision.allow ()
84
+
| "never" ->
85
+
Permission_state.deny tool_name;
86
+
Log.app (fun m -> m " → Denied (always)");
87
+
Decision.deny
88
+
~message:(Fmt.str "Tool %s permanently blocked" tool_name)
89
+
~interrupt:false
90
+
| _ ->
91
+
Log.app (fun m -> m " → Denied (invalid response)");
92
+
Decision.deny ~message:"Invalid permission response" ~interrupt:false
93
+
end
94
+
95
+
(* Demonstrate the permission system *)
96
+
let demo_permissions () =
97
+
Log.app (fun m -> m "🎭 Permission System Demonstration");
98
+
Log.app (fun m -> m "==================================\n");
99
+
100
+
(* Simulate permission requests *)
101
+
let tools = [ "Read"; "Write"; "Bash"; "Edit" ] in
102
+
103
+
Log.app (fun m -> m "This demo simulates permission requests.");
104
+
Log.app (fun m -> m "You can respond with: y/n/always/never\n");
105
+
106
+
(* Test each tool *)
107
+
List.iter
108
+
(fun tool_name ->
109
+
let input =
110
+
let open Jsont in
111
+
Object
112
+
( [
113
+
(("file_path", Meta.none), String ("/example/path.txt", Meta.none));
114
+
],
115
+
Meta.none )
116
+
in
117
+
let tool_input = Claude.Tool_input.of_json input in
118
+
let ctx =
119
+
Claude.Permissions.
120
+
{ tool_name; input = tool_input; suggested_rules = [] }
121
+
in
122
+
let decision = example_permission_callback ctx in
123
+
124
+
(* Show result *)
125
+
if Claude.Permissions.Decision.is_allow decision then
126
+
Log.info (fun m -> m "Result: Permission granted for %s" tool_name)
127
+
else
128
+
match Claude.Permissions.Decision.deny_message decision with
129
+
| Some message ->
130
+
Log.info (fun m ->
131
+
m "Result: Permission denied for %s - %s" tool_name message)
132
+
| None ->
133
+
Log.info (fun m -> m "Result: Permission denied for %s" tool_name))
134
+
tools;
135
+
136
+
(* Show final state *)
137
+
Permission_state.show ()
138
+
139
+
(* Also demonstrate discovery callback *)
140
+
let demo_discovery () =
141
+
Log.app (fun m -> m "\n\n🔍 Discovery Callback Demonstration");
142
+
Log.app (fun m -> m "====================================\n");
143
+
144
+
let discovered = ref [] in
145
+
let callback = Claude.Permissions.discovery discovered in
146
+
147
+
(* Simulate some tool requests *)
148
+
let requests =
149
+
let open Jsont in
150
+
[
151
+
( "Read",
152
+
Object
153
+
( [ (("file_path", Meta.none), String ("test.ml", Meta.none)) ],
154
+
Meta.none ) );
155
+
( "Bash",
156
+
Object
157
+
([ (("command", Meta.none), String ("ls -la", Meta.none)) ], Meta.none)
158
+
);
159
+
( "Write",
160
+
Object
161
+
( [ (("file_path", Meta.none), String ("output.txt", Meta.none)) ],
162
+
Meta.none ) );
163
+
]
164
+
in
165
+
166
+
Log.app (fun m -> m "Simulating tool requests with discovery callback...\n");
167
+
168
+
List.iter
169
+
(fun (tool_name, input) ->
170
+
Log.app (fun m -> m " Request: %s" tool_name);
171
+
let tool_input = Claude.Tool_input.of_json input in
172
+
let ctx =
173
+
Claude.Permissions.
174
+
{ tool_name; input = tool_input; suggested_rules = [] }
175
+
in
176
+
let _ = callback ctx in
177
+
())
178
+
requests;
179
+
180
+
Log.app (fun m -> m "\n📋 Discovered permissions:");
181
+
if !discovered = [] then Log.app (fun m -> m " None")
182
+
else
183
+
List.iter
184
+
(fun rule ->
185
+
Log.app (fun m ->
186
+
m " - %s%s"
187
+
(Claude.Permissions.Rule.tool_name rule)
188
+
(match Claude.Permissions.Rule.rule_content rule with
189
+
| Some content -> Fmt.str " (content: %s)" content
190
+
| None -> "")))
191
+
!discovered
192
+
193
+
let main () =
194
+
demo_permissions ();
195
+
demo_discovery ()
196
+
197
+
(* Command-line interface *)
198
+
open Cmdliner
199
+
200
+
let main_term =
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
+
if level = None then Logs.set_level (Some Logs.App)
206
+
in
207
+
let run style level =
208
+
setup_log style level;
209
+
main ()
210
+
in
211
+
Term.(const run $ Fmt_cli.style_renderer () $ Logs_cli.level ())
212
+
213
+
let cmd =
214
+
let doc = "Demonstrate permission callbacks and discovery" in
215
+
let man =
216
+
[
217
+
`S Manpage.s_description;
218
+
`P
219
+
"This program demonstrates how permission callbacks work in the Claude \
220
+
OCaml library.";
221
+
`P
222
+
"It simulates permission requests and shows how to implement custom \
223
+
callbacks.";
224
+
]
225
+
in
226
+
let info = Cmd.info "simulated_permissions" ~version:"1.0" ~doc ~man in
227
+
Cmd.v info main_term
228
+
229
+
let () = exit (Cmd.eval cmd)
+284
examples/structured_error_demo.ml
+284
examples/structured_error_demo.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
+
Claude.Control.Response.error_detail ~code:`Method_not_found
16
+
~message:"Method not found" ()
17
+
in
18
+
Fmt.pr "✓ Created error: [%d] %s\n" error1.code error1.message;
19
+
20
+
(* Create an error without additional data for simplicity *)
21
+
let error2 =
22
+
Claude.Control.Response.error_detail ~code:`Invalid_params
23
+
~message:"Invalid parameters" ()
24
+
in
25
+
Fmt.pr "✓ Created error: [%d] %s\n" error2.code error2.message;
26
+
27
+
(* Encode and decode an error response *)
28
+
let error_resp =
29
+
Claude.Control.Response.error ~request_id:"test-123" ~error:error2 ()
30
+
in
31
+
32
+
match Jsont.Json.encode Claude.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
+
Fmt.pr "✓ Encoded error response: %s\n" json_str;
40
+
41
+
(* Decode it back *)
42
+
match Jsont.Json.decode Claude.Control.Response.jsont json with
43
+
| Ok (Claude.Control.Response.Error decoded) ->
44
+
Fmt.pr "✓ Decoded error: [%d] %s\n" decoded.error.code
45
+
decoded.error.message
46
+
| Ok _ -> print_endline "✗ Wrong response type"
47
+
| Error e -> Fmt.pr "✗ Decode failed: %s\n" e)
48
+
| Error e -> Fmt.pr "✗ 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 = Claude.Control.Response.error_detail ~code ~message:msg () in
68
+
Fmt.pr "✓ Error [%d]: %s (typed)\n" err.code err.message)
69
+
errors
70
+
71
+
let process_error_responses messages =
72
+
let error_found = ref false in
73
+
let text_error_found = ref false in
74
+
List.iter
75
+
(fun resp ->
76
+
match resp with
77
+
| Claude.Response.Error err ->
78
+
error_found := true;
79
+
Fmt.pr "✓ Received structured error response: %s\n"
80
+
(Claude.Response.Error.message err);
81
+
Fmt.pr " Is system error: %b\n"
82
+
(Claude.Response.Error.is_system_error err);
83
+
Fmt.pr " Is assistant error: %b\n"
84
+
(Claude.Response.Error.is_assistant_error err)
85
+
| Claude.Response.Text text ->
86
+
let content = Claude.Response.Text.content text in
87
+
if
88
+
String.length content > 0
89
+
&& (String.contains content '4' || String.contains content 'e')
90
+
then begin
91
+
text_error_found := true;
92
+
Fmt.pr "✓ Received error as text: %s\n" content
93
+
end
94
+
| Claude.Response.Complete result ->
95
+
Fmt.pr " Complete (duration: %dms)\n"
96
+
(Claude.Response.Complete.duration_ms result)
97
+
| _ -> ())
98
+
messages;
99
+
100
+
if !error_found then
101
+
Fmt.pr "✓ Successfully caught structured error response\n"
102
+
else if !text_error_found then
103
+
Fmt.pr "✓ Successfully caught error (returned as text)\n"
104
+
else Fmt.pr "✗ No error was returned (unexpected)\n"
105
+
106
+
let test_provoke_api_error ~sw ~env =
107
+
print_endline "\nTesting API error from Claude...";
108
+
109
+
(* Configure client with an invalid model to provoke an API error *)
110
+
let options =
111
+
Claude.Options.default
112
+
|> Claude.Options.with_model
113
+
(Claude.Model.of_string "invalid-model-that-does-not-exist")
114
+
in
115
+
116
+
Fmt.pr "Creating client with invalid model...\n";
117
+
118
+
try
119
+
let client =
120
+
Claude.Client.v ~options ~sw ~process_mgr:env#process_mgr ~clock:env#clock
121
+
()
122
+
in
123
+
124
+
Fmt.pr "Sending query to provoke API error...\n";
125
+
Claude.Client.query client
126
+
"Hello, this should fail with an invalid model error";
127
+
128
+
(* Process responses to see if we get an error *)
129
+
let messages = Claude.Client.receive_all client in
130
+
process_error_responses messages
131
+
with
132
+
| Claude.Transport.Connection_error msg ->
133
+
Fmt.pr "✓ Connection error as expected: %s\n" msg
134
+
| exn ->
135
+
Fmt.pr "✗ Unexpected exception: %s\n" (Printexc.to_string exn);
136
+
Printexc.print_backtrace stdout
137
+
138
+
let test_control_protocol_error () =
139
+
print_endline "\nTesting control protocol error encoding/decoding...";
140
+
141
+
(* Test that we can create and encode a control protocol error using polymorphic variant codes *)
142
+
let error_detail =
143
+
Claude.Control.Response.error_detail ~code:`Invalid_params
144
+
~message:"Invalid params for permission request"
145
+
~data:
146
+
(Jsont.Object
147
+
( [
148
+
( ("tool_name", Jsont.Meta.none),
149
+
Jsont.String ("Write", Jsont.Meta.none) );
150
+
( ("reason", Jsont.Meta.none),
151
+
Jsont.String
152
+
("Missing required file_path parameter", Jsont.Meta.none) );
153
+
],
154
+
Jsont.Meta.none ))
155
+
()
156
+
in
157
+
158
+
let error_response =
159
+
Claude.Control.Response.error ~request_id:"test-req-456" ~error:error_detail
160
+
()
161
+
in
162
+
163
+
match Jsont.Json.encode Claude.Control.Response.jsont error_response with
164
+
| Ok json -> (
165
+
let json_str =
166
+
match Jsont_bytesrw.encode_string' Jsont.json json with
167
+
| Ok s -> s
168
+
| Error e -> Jsont.Error.to_string e
169
+
in
170
+
Fmt.pr "✓ Encoded control error with data:\n %s\n" json_str;
171
+
172
+
(* Verify we can decode it back *)
173
+
match Jsont.Json.decode Claude.Control.Response.jsont json with
174
+
| Ok (Claude.Control.Response.Error decoded) -> (
175
+
Fmt.pr "✓ Decoded control error:\n";
176
+
Fmt.pr " Code: %d\n" decoded.error.code;
177
+
Fmt.pr " Message: %s\n" decoded.error.message;
178
+
Fmt.pr " Has data: %b\n" (Option.is_some decoded.error.data);
179
+
match decoded.error.data with
180
+
| Some data ->
181
+
let data_str =
182
+
match Jsont_bytesrw.encode_string' Jsont.json data with
183
+
| Ok s -> s
184
+
| Error e -> Jsont.Error.to_string e
185
+
in
186
+
Fmt.pr " Data: %s\n" data_str
187
+
| None -> ())
188
+
| Ok _ -> print_endline "✗ Wrong response type"
189
+
| Error e -> Fmt.pr "✗ Decode failed: %s\n" e)
190
+
| Error e -> Fmt.pr "✗ Encode failed: %s\n" e
191
+
192
+
let process_hook_responses messages =
193
+
let hook_called = ref false in
194
+
let error_found = ref false in
195
+
List.iter
196
+
(fun resp ->
197
+
match resp with
198
+
| Claude.Response.Tool_use tool ->
199
+
let tool_name = Claude.Response.Tool_use.name tool in
200
+
if tool_name = "Write" then begin
201
+
hook_called := true;
202
+
Fmt.pr "✓ Write tool was called (hook intercepted it)\n"
203
+
end
204
+
| Claude.Response.Error err ->
205
+
error_found := true;
206
+
Fmt.pr " Error response: %s\n" (Claude.Response.Error.message err)
207
+
| Claude.Response.Complete _ -> Fmt.pr " Query completed\n"
208
+
| _ -> ())
209
+
messages;
210
+
211
+
if !hook_called then Fmt.pr "✓ Hook was triggered, exception caught by SDK\n"
212
+
else
213
+
Fmt.pr
214
+
" Note: Hook may not have been called if query didn't use Write tool\n";
215
+
216
+
Fmt.pr "✓ Test completed (SDK sent -32603 Internal Error to CLI)\n"
217
+
218
+
let test_hook_error ~sw ~env =
219
+
print_endline "\nTesting hook callback errors trigger JSON-RPC error codes...";
220
+
221
+
(* Create a hook that will throw an exception *)
222
+
let failing_hook input =
223
+
Fmt.pr "✓ Hook called for tool: %s\n"
224
+
input.Claude.Hooks.Pre_tool_use.tool_name;
225
+
failwith "Intentional hook failure to test error handling"
226
+
in
227
+
228
+
(* Register the failing hook *)
229
+
let hooks =
230
+
Claude.Hooks.empty
231
+
|> Claude.Hooks.on_pre_tool_use ~pattern:"Write" failing_hook
232
+
in
233
+
234
+
let options =
235
+
Claude.Options.default
236
+
|> Claude.Options.with_hooks hooks
237
+
|> Claude.Options.with_model (Claude.Model.of_string "haiku")
238
+
in
239
+
240
+
Fmt.pr "Creating client with failing hook...\n";
241
+
242
+
try
243
+
let client =
244
+
Claude.Client.v ~options ~sw ~process_mgr:env#process_mgr ~clock:env#clock
245
+
()
246
+
in
247
+
248
+
Fmt.pr "Asking Claude to write a file (should trigger failing hook)...\n";
249
+
Claude.Client.query client "Write 'test' to /tmp/test_hook_error.txt";
250
+
251
+
(* Process responses *)
252
+
let messages = Claude.Client.receive_all client in
253
+
process_hook_responses messages
254
+
with exn ->
255
+
Fmt.pr "Exception during test: %s\n" (Printexc.to_string exn);
256
+
Printexc.print_backtrace stdout
257
+
258
+
let run_all_tests env =
259
+
print_endline "=== Structured Error Tests ===";
260
+
test_create_error_detail ();
261
+
test_error_code_conventions ();
262
+
test_control_protocol_error ();
263
+
264
+
(* Test with actual Claude invocation *)
265
+
Switch.run @@ fun sw ->
266
+
test_provoke_api_error ~sw ~env;
267
+
268
+
(* Test hook errors that trigger JSON-RPC error codes *)
269
+
Switch.run @@ fun sw ->
270
+
test_hook_error ~sw ~env;
271
+
272
+
print_endline "\n=== All Structured Error Tests Completed ==="
273
+
274
+
let () =
275
+
Eio_main.run @@ fun env ->
276
+
try run_all_tests env with
277
+
| Claude.Transport.CLI_not_found msg ->
278
+
Fmt.epr "Error: Claude CLI not found\n%s\n" msg;
279
+
Fmt.epr "Make sure 'claude' is installed and in your PATH\n";
280
+
exit 1
281
+
| exn ->
282
+
Fmt.epr "Fatal error: %s\n" (Printexc.to_string exn);
283
+
Printexc.print_backtrace stderr;
284
+
exit 1
+210
examples/structured_output_demo.ml
+210
examples/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 typed_prop typ desc =
17
+
let open Jsont in
18
+
Object
19
+
( [
20
+
(("type", Meta.none), String (typ, Meta.none));
21
+
(("description", Meta.none), String (desc, Meta.none));
22
+
],
23
+
Meta.none )
24
+
25
+
let complexity_rating_prop =
26
+
let open Jsont in
27
+
Object
28
+
( [
29
+
(("type", Meta.none), String ("string", Meta.none));
30
+
( ("enum", Meta.none),
31
+
Array
32
+
( [
33
+
String ("low", Meta.none);
34
+
String ("medium", Meta.none);
35
+
String ("high", Meta.none);
36
+
],
37
+
Meta.none ) );
38
+
( ("description", Meta.none),
39
+
String ("Overall complexity rating", Meta.none) );
40
+
],
41
+
Meta.none )
42
+
43
+
let key_findings_prop =
44
+
let open Jsont in
45
+
Object
46
+
( [
47
+
(("type", Meta.none), String ("array", Meta.none));
48
+
( ("items", Meta.none),
49
+
Object
50
+
([ (("type", Meta.none), String ("string", Meta.none)) ], Meta.none)
51
+
);
52
+
( ("description", Meta.none),
53
+
String ("List of key findings from the analysis", Meta.none) );
54
+
],
55
+
Meta.none )
56
+
57
+
let analysis_properties =
58
+
let open Jsont in
59
+
Object
60
+
( [
61
+
( ("file_count", Meta.none),
62
+
typed_prop "integer" "Total number of files analyzed" );
63
+
( ("has_tests", Meta.none),
64
+
typed_prop "boolean" "Whether the codebase has test files" );
65
+
( ("primary_language", Meta.none),
66
+
typed_prop "string" "The primary programming language used" );
67
+
(("complexity_rating", Meta.none), complexity_rating_prop);
68
+
(("key_findings", Meta.none), key_findings_prop);
69
+
],
70
+
Meta.none )
71
+
72
+
let analysis_schema =
73
+
let open Jsont in
74
+
Object
75
+
( [
76
+
(("type", Meta.none), String ("object", Meta.none));
77
+
(("properties", Meta.none), analysis_properties);
78
+
( ("required", Meta.none),
79
+
Array
80
+
( [
81
+
String ("file_count", Meta.none);
82
+
String ("has_tests", Meta.none);
83
+
String ("primary_language", Meta.none);
84
+
String ("complexity_rating", Meta.none);
85
+
String ("key_findings", Meta.none);
86
+
],
87
+
Meta.none ) );
88
+
(("additionalProperties", Meta.none), Bool (false, Meta.none));
89
+
],
90
+
Meta.none )
91
+
92
+
let display_parsed_analysis output =
93
+
Fmt.pr "\n=== Structured Output ===\n";
94
+
Fmt.pr "%s\n\n" (Json_utils.to_string ~minify:false output);
95
+
96
+
(* Parse the structured output *)
97
+
let file_count =
98
+
Json_utils.int output "file_count" |> Option.value ~default:0
99
+
in
100
+
let has_tests =
101
+
Json_utils.bool output "has_tests" |> Option.value ~default:false
102
+
in
103
+
let language =
104
+
Json_utils.string output "primary_language"
105
+
|> Option.value ~default:"unknown"
106
+
in
107
+
let complexity =
108
+
Json_utils.string output "complexity_rating"
109
+
|> Option.value ~default:"unknown"
110
+
in
111
+
let findings =
112
+
match Json_utils.array output "key_findings" with
113
+
| Some items ->
114
+
List.filter_map (fun json -> Json_utils.as_string json) items
115
+
| None -> []
116
+
in
117
+
118
+
Fmt.pr "=== Parsed Analysis ===\n";
119
+
Fmt.pr "File Count: %d\n" file_count;
120
+
Fmt.pr "Has Tests: %b\n" has_tests;
121
+
Fmt.pr "Primary Language: %s\n" language;
122
+
Fmt.pr "Complexity: %s\n" complexity;
123
+
Fmt.pr "Key Findings:\n";
124
+
List.iter (fun finding -> Fmt.pr " - %s\n" finding) findings
125
+
126
+
let process_analysis_responses responses =
127
+
Seq.iter
128
+
(function
129
+
| C.Response.Text text ->
130
+
Fmt.pr "\nAssistant text:\n";
131
+
Fmt.pr " %s\n" (C.Response.Text.content text)
132
+
| C.Response.Tool_use tool ->
133
+
Fmt.pr " Using tool: %s\n" (C.Response.Tool_use.name tool)
134
+
| C.Response.Complete result -> (
135
+
Fmt.pr "\n=== Result ===\n";
136
+
Fmt.pr "Duration: %dms\n" (C.Response.Complete.duration_ms result);
137
+
Fmt.pr "Cost: $%.4f\n"
138
+
(Option.value
139
+
(C.Response.Complete.total_cost_usd result)
140
+
~default:0.0);
141
+
142
+
(* Extract and display structured output *)
143
+
match C.Response.Complete.structured_output result with
144
+
| Some output -> display_parsed_analysis output
145
+
| None -> (
146
+
Fmt.pr "No structured output received\n";
147
+
match C.Response.Complete.result_text result with
148
+
| Some text -> Fmt.pr "Text result: %s\n" text
149
+
| None -> ()))
150
+
| C.Response.Init _ -> Fmt.pr "Session initialized\n"
151
+
| C.Response.Error err ->
152
+
Fmt.pr "Error: %s\n" (C.Response.Error.message err)
153
+
| _ -> ())
154
+
responses
155
+
156
+
let run_codebase_analysis env =
157
+
Fmt.pr "\n=== Codebase Analysis with Structured Output ===\n\n";
158
+
159
+
(* Create structured output format from the schema *)
160
+
let output_format = Claude.Structured_output.of_json_schema analysis_schema in
161
+
162
+
(* Configure Claude with structured output *)
163
+
let options =
164
+
C.Options.default
165
+
|> C.Options.with_output_format output_format
166
+
|> C.Options.with_allowed_tools [ "Read"; "Glob"; "Grep" ]
167
+
|> C.Options.with_system_prompt
168
+
"You are a code analysis assistant. Analyze codebases and provide \
169
+
structured output matching the given JSON Schema."
170
+
in
171
+
172
+
Fmt.pr "Structured output format configured\n";
173
+
Fmt.pr "Schema: %s\n\n" (Json_utils.to_string ~minify:false analysis_schema);
174
+
175
+
(* Create Claude client and query *)
176
+
Eio.Switch.run @@ fun sw ->
177
+
let process_mgr = Eio.Stdenv.process_mgr env in
178
+
let clock = Eio.Stdenv.clock env in
179
+
let client = C.Client.v ~sw ~process_mgr ~clock ~options () in
180
+
181
+
let prompt =
182
+
"Please analyze the current codebase structure. Look at the files, \
183
+
identify the primary language, count files, check for tests, assess \
184
+
complexity, and provide key findings. Return your analysis in the \
185
+
structured JSON format I specified."
186
+
in
187
+
188
+
Fmt.pr "Sending query: %s\n\n" prompt;
189
+
C.Client.query client prompt;
190
+
191
+
(* Process responses *)
192
+
let responses = C.Client.receive client in
193
+
process_analysis_responses responses;
194
+
195
+
Fmt.pr "\nDone!\n"
196
+
197
+
let () =
198
+
Eio_main.run @@ fun env ->
199
+
try run_codebase_analysis env with
200
+
| C.Transport.CLI_not_found msg ->
201
+
Fmt.epr "Error: Claude CLI not found\n%s\n" msg;
202
+
Fmt.epr "Make sure 'claude' is installed and in your PATH\n";
203
+
exit 1
204
+
| C.Transport.Connection_error msg ->
205
+
Fmt.epr "Connection error: %s\n" msg;
206
+
exit 1
207
+
| exn ->
208
+
Fmt.epr "Unexpected error: %s\n" (Printexc.to_string exn);
209
+
Printexc.print_backtrace stderr;
210
+
exit 1
+89
examples/structured_output_simple.ml
+89
examples/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 person_schema =
15
+
let open Jsont in
16
+
Object
17
+
( [
18
+
(("type", Meta.none), String ("object", Meta.none));
19
+
( ("properties", Meta.none),
20
+
Object
21
+
( [
22
+
( ("name", Meta.none),
23
+
Object
24
+
( [ (("type", Meta.none), String ("string", Meta.none)) ],
25
+
Meta.none ) );
26
+
( ("age", Meta.none),
27
+
Object
28
+
( [ (("type", Meta.none), String ("integer", Meta.none)) ],
29
+
Meta.none ) );
30
+
( ("occupation", Meta.none),
31
+
Object
32
+
( [ (("type", Meta.none), String ("string", Meta.none)) ],
33
+
Meta.none ) );
34
+
],
35
+
Meta.none ) );
36
+
( ("required", Meta.none),
37
+
Array
38
+
( [
39
+
String ("name", Meta.none);
40
+
String ("age", Meta.none);
41
+
String ("occupation", Meta.none);
42
+
],
43
+
Meta.none ) );
44
+
],
45
+
Meta.none )
46
+
47
+
let simple_example env =
48
+
Fmt.pr "\n=== Simple Structured Output Example ===\n\n";
49
+
50
+
let output_format = Claude.Structured_output.of_json_schema person_schema in
51
+
52
+
let options =
53
+
C.Options.default
54
+
|> C.Options.with_output_format output_format
55
+
|> C.Options.with_max_turns 1
56
+
in
57
+
58
+
Fmt.pr "Asking Claude to provide structured data...\n\n";
59
+
60
+
Eio.Switch.run @@ fun sw ->
61
+
let process_mgr = Eio.Stdenv.process_mgr env in
62
+
let clock = Eio.Stdenv.clock env in
63
+
let client = C.Client.v ~sw ~process_mgr ~clock ~options () in
64
+
65
+
C.Client.query client
66
+
"Tell me about a famous computer scientist. Provide their name, age, and \
67
+
occupation in the exact JSON structure I specified.";
68
+
69
+
let responses = C.Client.receive_all client in
70
+
List.iter
71
+
(function
72
+
| C.Response.Complete result -> (
73
+
Fmt.pr "Response received!\n";
74
+
match C.Response.Complete.structured_output result with
75
+
| Some json ->
76
+
Fmt.pr "\nStructured Output:\n%s\n"
77
+
(Json_utils.to_string ~minify:false json)
78
+
| None -> Fmt.pr "No structured output\n")
79
+
| C.Response.Error err ->
80
+
Fmt.pr "Error: %s\n" (C.Response.Error.message err)
81
+
| _ -> ())
82
+
responses
83
+
84
+
let () =
85
+
Eio_main.run @@ fun env ->
86
+
try simple_example env
87
+
with exn ->
88
+
Fmt.epr "Error: %s\n" (Printexc.to_string exn);
89
+
exit 1
+27
lib/claude.ml
+27
lib/claude.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Err = Err
7
+
module Client = Client
8
+
module Options = Options
9
+
module Response = Response
10
+
module Handler = Handler
11
+
module Tool_input = Tool_input
12
+
module Content_block = Content_block
13
+
module Incoming = Incoming
14
+
module Message = Message
15
+
module Permissions = Permissions
16
+
module Hooks = Hooks
17
+
module Server_info = Server_info
18
+
module Transport = Transport
19
+
module Model = Model
20
+
module Structured_output = Structured_output
21
+
module Control = Control
22
+
module Outgoing = Outgoing
23
+
module Unknown = Unknown
24
+
25
+
(* New MCP-based custom tool support *)
26
+
module Tool = Tool
27
+
module Mcp_server = Mcp_server
+270
lib/claude.mli
+270
lib/claude.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** OCaml Eio library for Claude Code CLI.
7
+
8
+
This library provides an interface to the Claude Code command-line interface
9
+
using OCaml's Eio concurrency library. It wraps Claude CLI invocations with
10
+
JSON streaming for asynchronous communication.
11
+
12
+
{1 Overview}
13
+
14
+
The Claude library enables you to:
15
+
- Send messages to Claude and receive streaming responses
16
+
- Control tool permissions and execution
17
+
- Configure system prompts and model parameters
18
+
- Handle content blocks including text, tool use, and thinking blocks
19
+
- Manage sessions with proper resource cleanup
20
+
21
+
{1 Architecture}
22
+
23
+
The library is structured into two layers:
24
+
25
+
{2 High-Level API}
26
+
- {!Client}: High-level client interface for interacting with Claude
27
+
- {!Response}: High-level response events from Claude
28
+
- {!Handler}: Object-oriented response handler with sensible defaults
29
+
- {!Options}: Configuration options for Claude sessions
30
+
- {!Permissions}: Fine-grained permission system for tool usage
31
+
- {!Hooks}: Fully typed hook callbacks for event interception
32
+
33
+
{2 Domain Types}
34
+
- {!Content_block}: Content blocks (text, tool use, tool results, thinking)
35
+
- {!Message}: Messages exchanged with Claude (user, assistant, system,
36
+
result)
37
+
- {!Tool_input}: Opaque tool input with typed accessors
38
+
- {!Server_info}: Server capabilities and metadata
39
+
40
+
{1 Quick Start}
41
+
42
+
{[
43
+
open Eio.Std
44
+
45
+
let () =
46
+
Eio_main.run @@ fun env ->
47
+
Switch.run @@ fun sw ->
48
+
let client =
49
+
Claude.Client.v ~sw ~process_mgr:(Eio.Stdenv.process_mgr env) ()
50
+
in
51
+
52
+
Claude.Client.query client "What is 2+2?";
53
+
54
+
let handler =
55
+
object
56
+
inherit Claude.Handler.default
57
+
method! on_text t = print_endline (Claude.Response.Text.content t)
58
+
end
59
+
in
60
+
61
+
Claude.Client.run client ~handler
62
+
]}
63
+
64
+
{1 Response Handling}
65
+
66
+
The library provides two ways to handle responses:
67
+
68
+
{2 Object-Oriented Handler (Recommended)}
69
+
70
+
Subclass {!Handler.default} and override only the methods you need:
71
+
72
+
{[
73
+
let my_handler =
74
+
object
75
+
inherit Claude.Handler.default
76
+
method! on_text t = print_endline (Claude.Response.Text.content t)
77
+
78
+
method! on_tool_use t =
79
+
Printf.printf "Tool: %s\n" (Claude.Response.Tool_use.name t)
80
+
81
+
method! on_complete c =
82
+
Printf.printf "Done! Cost: $%.4f\n"
83
+
(Option.value ~default:0.0
84
+
(Claude.Response.Complete.total_cost_usd c))
85
+
end
86
+
in
87
+
88
+
Claude.Client.run client ~handler:my_handler
89
+
]}
90
+
91
+
{2 Functional Sequence}
92
+
93
+
For more control, use {!Client.receive} to get a lazy sequence:
94
+
95
+
{[
96
+
Claude.Client.receive client
97
+
|> Seq.iter (function
98
+
| Claude.Response.Text t -> print_endline (Claude.Response.Text.content t)
99
+
| Claude.Response.Complete c -> Printf.printf "Done!\n"
100
+
| _ -> ())
101
+
]}
102
+
103
+
{1 Tool Permissions}
104
+
105
+
Control which tools Claude can use:
106
+
107
+
{[
108
+
let options =
109
+
Claude.Options.default
110
+
|> Claude.Options.with_allowed_tools [ "Read"; "Write"; "Bash" ]
111
+
|> Claude.Options.with_permission_mode
112
+
Claude.Permissions.Mode.Accept_edits
113
+
]}
114
+
115
+
{2 Custom Permission Callbacks}
116
+
117
+
Implement custom logic for tool approval:
118
+
119
+
{[
120
+
let my_callback ctx =
121
+
if ctx.Claude.Permissions.tool_name = "Bash" then
122
+
Claude.Permissions.Decision.deny ~message:"Bash not allowed"
123
+
~interrupt:false
124
+
else Claude.Permissions.Decision.allow ()
125
+
126
+
let options =
127
+
Claude.Options.default
128
+
|> Claude.Options.with_permission_callback my_callback
129
+
]}
130
+
131
+
{1 Typed Hooks}
132
+
133
+
Intercept and control tool execution with fully typed callbacks:
134
+
135
+
{[
136
+
let hooks =
137
+
Claude.Hooks.empty
138
+
|> Claude.Hooks.on_pre_tool_use ~pattern:"Bash" (fun input ->
139
+
if
140
+
String.is_prefix ~prefix:"rm"
141
+
(input.tool_input
142
+
|> Claude.Tool_input.string "command"
143
+
|> Option.value ~default:"")
144
+
then Claude.Hooks.Pre_tool_use.deny ~reason:"Dangerous command" ()
145
+
else Claude.Hooks.Pre_tool_use.continue ())
146
+
147
+
let options = Claude.Options.default |> Claude.Options.with_hooks hooks
148
+
]}
149
+
150
+
{1 Error Handling}
151
+
152
+
The library uses a structured exception type {!Err.E} for all errors:
153
+
154
+
{[
155
+
try Claude.Client.query client "Hello"
156
+
with Claude.Err.E err ->
157
+
Printf.eprintf "Error: %s\n" (Claude.Err.to_string err)
158
+
]}
159
+
160
+
Error types include:
161
+
- {!Err.Cli_not_found}: Claude CLI not found
162
+
- {!Err.Process_error}: Process execution failure
163
+
- {!Err.Protocol_error}: JSON/protocol parsing error
164
+
- {!Err.Timeout}: Operation timed out
165
+
- {!Err.Permission_denied}: Tool permission denied
166
+
- {!Err.Hook_error}: Hook callback error
167
+
168
+
{1 Logging}
169
+
170
+
The library uses the Logs library for structured logging. Each module has
171
+
its own log source allowing fine-grained control:
172
+
173
+
{[
174
+
Logs.Src.set_level Claude.Client.src (Some Logs.Debug);
175
+
Logs.Src.set_level Claude.Transport.src (Some Logs.Info)
176
+
]} *)
177
+
178
+
(** {1 Core Modules} *)
179
+
180
+
module Err = Err
181
+
(** Error handling with structured exception type. *)
182
+
183
+
module Client = Client
184
+
(** High-level client interface for Claude interactions. *)
185
+
186
+
module Options = Options
187
+
(** Configuration options for Claude sessions. *)
188
+
189
+
module Response = Response
190
+
(** High-level response events from Claude. *)
191
+
192
+
module Handler = Handler
193
+
(** Object-oriented response handler with sensible defaults. *)
194
+
195
+
(** {1 Domain Types} *)
196
+
197
+
module Tool_input = Tool_input
198
+
(** Opaque tool input with typed accessors. *)
199
+
200
+
module Content_block = Content_block
201
+
(** Content blocks for messages (text, tool use, tool results, thinking). *)
202
+
203
+
module Incoming = Incoming
204
+
(** Incoming messages from the Claude CLI (messages, control responses). *)
205
+
206
+
module Message = Message
207
+
(** Messages exchanged with Claude (user, assistant, system, result). *)
208
+
209
+
module Permissions = Permissions
210
+
(** Permission system for tool invocations. *)
211
+
212
+
module Hooks = Hooks
213
+
(** Fully typed hook callbacks for event interception. *)
214
+
215
+
module Server_info = Server_info
216
+
(** Server capabilities and metadata. *)
217
+
218
+
module Model = Model
219
+
(** Claude AI model identifiers. *)
220
+
221
+
module Structured_output = Structured_output
222
+
(** Structured output configuration using JSON Schema. *)
223
+
224
+
module Control = Control
225
+
(** Control protocol envelopes. *)
226
+
227
+
module Outgoing = Outgoing
228
+
(** Outgoing message envelopes for the CLI. *)
229
+
230
+
module Unknown = Unknown
231
+
(** Unknown JSON fields preserved during round-trip. *)
232
+
233
+
(** {1 Custom Tools (MCP)}
234
+
235
+
These modules enable custom tool definitions that run in-process via MCP
236
+
(Model Context Protocol). Unlike built-in tools which Claude CLI handles
237
+
internally, custom tools are executed by your application.
238
+
239
+
{2 Example}
240
+
241
+
{[
242
+
let greet =
243
+
Claude.Tool.v ~name:"greet" ~description:"Greet a user"
244
+
~input_schema:
245
+
(Claude.Tool.schema_object
246
+
[ ("name", Claude.Tool.schema_string) ]
247
+
~required:[ "name" ])
248
+
~handler:(fun args ->
249
+
match Claude.Tool_input.string args "name" with
250
+
| Some name -> Ok (Claude.Tool.text_result ("Hello, " ^ name ^ "!"))
251
+
| None -> Error "Missing name")
252
+
253
+
let server = Claude.Mcp_server.v ~name:"my-tools" ~tools:[ greet ] ()
254
+
255
+
let options =
256
+
Claude.Options.default
257
+
|> Claude.Options.with_mcp_server ~name:"tools" server
258
+
|> Claude.Options.with_allowed_tools [ "mcp__tools__greet" ]
259
+
]} *)
260
+
261
+
module Tool = Tool
262
+
(** Custom tool definitions for MCP servers. *)
263
+
264
+
module Mcp_server = Mcp_server
265
+
(** In-process MCP servers for custom tools. *)
266
+
267
+
(** {1 Infrastructure} *)
268
+
269
+
module Transport = Transport
270
+
(** Low-level transport layer for CLI communication. *)
+574
lib/client.ml
+574
lib/client.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let src = Logs.Src.create "claude.client" ~doc:"Claude client"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
(** Control response builders using Control codecs *)
11
+
module Control_response = struct
12
+
let success ~request_id ~response =
13
+
let resp = Control.Response.success ~request_id ?response () in
14
+
let ctrl = Control.response ~response:resp () in
15
+
Jsont.Json.encode Control.jsont ctrl
16
+
|> Err.ok ~msg:"Control_response.success: "
17
+
18
+
let error ~request_id ~code ~message ?data () =
19
+
let error_detail = Control.Response.error_detail ~code ~message ?data () in
20
+
let resp = Control.Response.error ~request_id ~error:error_detail () in
21
+
let ctrl = Control.response ~response:resp () in
22
+
Jsont.Json.encode Control.jsont ctrl
23
+
|> Err.ok ~msg:"Control_response.error: "
24
+
end
25
+
26
+
(* Helper functions for JSON manipulation using jsont *)
27
+
let json_to_string json =
28
+
Jsont_bytesrw.encode_string' Jsont.json json
29
+
|> Result.map_error Jsont.Error.to_string
30
+
|> Err.ok ~msg:""
31
+
32
+
(** Wire-level codec for hook matcher configuration sent to CLI. *)
33
+
module Hook_matcher_wire = struct
34
+
type t = { matcher : string option; hook_callback_ids : string list }
35
+
36
+
let jsont : t Jsont.t =
37
+
let make matcher hook_callback_ids = { matcher; hook_callback_ids } in
38
+
Jsont.Object.map ~kind:"HookMatcherWire" make
39
+
|> Jsont.Object.opt_mem "matcher" Jsont.string ~enc:(fun r -> r.matcher)
40
+
|> Jsont.Object.mem "hookCallbackIds" (Jsont.list Jsont.string)
41
+
~enc:(fun r -> r.hook_callback_ids)
42
+
|> Jsont.Object.finish
43
+
44
+
let encode matchers =
45
+
List.map
46
+
(fun m ->
47
+
Jsont.Json.encode jsont m |> Err.ok ~msg:"Hook_matcher_wire.encode: ")
48
+
matchers
49
+
|> Jsont.Json.list
50
+
end
51
+
52
+
type t = {
53
+
transport : Transport.t;
54
+
mutable permission_callback : Permissions.callback option;
55
+
mutable permission_log : Permissions.Rule.t list ref option;
56
+
hook_callbacks : (string, Jsont.json -> Hooks.result) Hashtbl.t;
57
+
mutable session_id : string option;
58
+
control_responses : (string, Jsont.json) Hashtbl.t;
59
+
control_mutex : Eio.Mutex.t;
60
+
control_condition : Eio.Condition.t;
61
+
clock : float Eio.Time.clock_ty Eio.Resource.t;
62
+
(* Track tool_use_ids we've already responded to, preventing duplicates *)
63
+
responded_tool_ids : (string, unit) Hashtbl.t;
64
+
(* In-process MCP servers for custom tools *)
65
+
mcp_servers : (string, Mcp_server.t) Hashtbl.t;
66
+
}
67
+
68
+
let session_id t = t.session_id
69
+
70
+
let handle_permission_request t ~request_id (req : Control.Request.permission) =
71
+
let tool_name = req.tool_name in
72
+
let input_json = req.input in
73
+
Log.info (fun m ->
74
+
m "Permission request for tool '%s' with input: %s" tool_name
75
+
(json_to_string input_json));
76
+
let suggestions = Option.value req.permission_suggestions ~default:[] in
77
+
let suggested_rules =
78
+
Permissions.extract_rules_from_proto_updates suggestions
79
+
in
80
+
81
+
(* Convert input to Tool_input.t *)
82
+
let input = Tool_input.of_json input_json in
83
+
84
+
(* Create context *)
85
+
let context : Permissions.context = { tool_name; input; suggested_rules } in
86
+
87
+
Log.info (fun m -> m "Invoking permission callback for tool: %s" tool_name);
88
+
let callback =
89
+
Option.value t.permission_callback ~default:Permissions.default_allow
90
+
in
91
+
let decision = callback context in
92
+
Log.info (fun m ->
93
+
m "Permission callback returned: %s"
94
+
(if Permissions.Decision.is_allow decision then "ALLOW" else "DENY"));
95
+
96
+
let lib_result =
97
+
Permissions.Decision.to_proto_result ~original_input:input decision
98
+
in
99
+
let response_data =
100
+
match Jsont.Json.encode Permissions.Result.jsont lib_result with
101
+
| Ok json -> json
102
+
| Error err ->
103
+
Log.err (fun m -> m "Failed to encode permission result: %s" err);
104
+
failwith "Permission result encoding failed"
105
+
in
106
+
let response =
107
+
Control_response.success ~request_id ~response:(Some response_data)
108
+
in
109
+
Log.info (fun m -> m "Sending control response: %s" (json_to_string response));
110
+
Transport.send t.transport response
111
+
112
+
let handle_hook_callback t ~request_id (req : Control.Request.hook_callback) =
113
+
let callback_id = req.callback_id in
114
+
let input = req.input in
115
+
let _tool_use_id = req.tool_use_id in
116
+
Log.info (fun m -> m "Hook callback request for callback_id: %s" callback_id);
117
+
118
+
try
119
+
let callback = Hashtbl.find t.hook_callbacks callback_id in
120
+
let result = callback input in
121
+
122
+
let result_json =
123
+
Jsont.Json.encode Hooks.result_jsont result
124
+
|> Err.ok ~msg:"Failed to encode hook result: "
125
+
in
126
+
Log.debug (fun m -> m "Hook result JSON: %s" (json_to_string result_json));
127
+
let response =
128
+
Control_response.success ~request_id ~response:(Some result_json)
129
+
in
130
+
Log.info (fun m -> m "Hook callback succeeded, sending response");
131
+
Transport.send t.transport response
132
+
with
133
+
| Not_found ->
134
+
let error_msg = Fmt.str "Hook callback not found: %s" callback_id in
135
+
Log.err (fun m -> m "%s" error_msg);
136
+
Transport.send t.transport
137
+
(Control_response.error ~request_id ~code:`Method_not_found
138
+
~message:error_msg ())
139
+
| exn ->
140
+
let error_msg =
141
+
Fmt.str "Hook callback error: %s" (Printexc.to_string exn)
142
+
in
143
+
Log.err (fun m -> m "%s" error_msg);
144
+
Transport.send t.transport
145
+
(Control_response.error ~request_id ~code:`Internal_error
146
+
~message:error_msg ())
147
+
148
+
let handle_mcp_message t ~request_id (req : Control.Request.mcp_message) =
149
+
let module J = Jsont.Json in
150
+
let server_name = req.server_name in
151
+
let message = req.message in
152
+
Log.info (fun m -> m "MCP request for server '%s'" server_name);
153
+
154
+
match Hashtbl.find_opt t.mcp_servers server_name with
155
+
| None ->
156
+
let error_msg = Fmt.str "MCP server '%s' not found" server_name in
157
+
Log.err (fun m -> m "%s" error_msg);
158
+
(* Return JSONRPC error in mcp_response format *)
159
+
let mcp_error =
160
+
J.object'
161
+
[
162
+
J.mem (J.name "jsonrpc") (J.string "2.0");
163
+
J.mem (J.name "id") (J.null ());
164
+
J.mem (J.name "error")
165
+
(J.object'
166
+
[
167
+
J.mem (J.name "code") (J.number (-32601.0));
168
+
J.mem (J.name "message") (J.string error_msg);
169
+
]);
170
+
]
171
+
in
172
+
let response_data =
173
+
J.object' [ J.mem (J.name "mcp_response") mcp_error ]
174
+
in
175
+
let response =
176
+
Control_response.success ~request_id ~response:(Some response_data)
177
+
in
178
+
Transport.send t.transport response
179
+
| Some server ->
180
+
let mcp_response = Mcp_server.handle_json_message server message in
181
+
Log.debug (fun m -> m "MCP response: %s" (json_to_string mcp_response));
182
+
let response_data =
183
+
J.object' [ J.mem (J.name "mcp_response") mcp_response ]
184
+
in
185
+
let response =
186
+
Control_response.success ~request_id ~response:(Some response_data)
187
+
in
188
+
Transport.send t.transport response
189
+
190
+
let handle_control_request t (ctrl_req : Control.control_request) =
191
+
let request_id = ctrl_req.request_id in
192
+
Log.info (fun m -> m "Handling control request: %s" request_id);
193
+
194
+
match ctrl_req.request with
195
+
| Control.Request.Permission req ->
196
+
handle_permission_request t ~request_id req
197
+
| Control.Request.Hook_callback req -> handle_hook_callback t ~request_id req
198
+
| Control.Request.Mcp_message req -> handle_mcp_message t ~request_id req
199
+
| _ ->
200
+
(* Other request types not handled here *)
201
+
let error_msg = "Unsupported control request type" in
202
+
Transport.send t.transport
203
+
(Control_response.error ~request_id ~code:`Invalid_request
204
+
~message:error_msg ())
205
+
206
+
let handle_control_response t control_resp =
207
+
let request_id =
208
+
match control_resp.Control.response with
209
+
| Control.Response.Success s -> s.request_id
210
+
| Control.Response.Error e -> e.request_id
211
+
in
212
+
Log.debug (fun m ->
213
+
m "Received control response for request_id: %s" request_id);
214
+
215
+
(* Store the response as JSON and signal waiting threads *)
216
+
let json =
217
+
Jsont.Json.encode Control.control_response_jsont control_resp
218
+
|> Err.ok ~msg:"Failed to encode control response: "
219
+
in
220
+
Eio.Mutex.use_rw ~protect:false t.control_mutex (fun () ->
221
+
Hashtbl.replace t.control_responses request_id json;
222
+
Eio.Condition.broadcast t.control_condition)
223
+
224
+
let handle_raw_messages t =
225
+
let rec loop () =
226
+
match Transport.receive_line t.transport with
227
+
| None ->
228
+
(* EOF *)
229
+
Log.debug (fun m -> m "Handle messages: EOF received");
230
+
Seq.Nil
231
+
| Some line -> (
232
+
(* Use unified Incoming codec for all message types *)
233
+
match Jsont_bytesrw.decode_string' Incoming.jsont line with
234
+
| Ok incoming -> Seq.Cons (incoming, loop)
235
+
| Error err ->
236
+
Log.err (fun m ->
237
+
m "Failed to decode incoming message: %s\nLine: %s"
238
+
(Jsont.Error.to_string err)
239
+
line);
240
+
loop ())
241
+
in
242
+
Log.debug (fun m -> m "Starting message handler");
243
+
loop
244
+
245
+
let handle_messages t =
246
+
let raw_seq = handle_raw_messages t in
247
+
let rec loop raw_seq =
248
+
match raw_seq () with
249
+
| Seq.Nil -> Seq.Nil
250
+
| Seq.Cons (incoming, rest) -> (
251
+
match incoming with
252
+
| Incoming.Message msg ->
253
+
Log.info (fun m -> m "← %a" Message.pp msg);
254
+
255
+
(* Extract session ID from system messages *)
256
+
(match msg with
257
+
| Message.System sys ->
258
+
Message.System.session_id sys
259
+
|> Option.iter (fun session_id ->
260
+
t.session_id <- Some session_id;
261
+
Log.debug (fun m -> m "Stored session ID: %s" session_id))
262
+
| _ -> ());
263
+
264
+
(* Convert message to response events *)
265
+
let responses = Response.of_message msg in
266
+
emit_responses responses rest
267
+
| Incoming.Control_response resp ->
268
+
handle_control_response t resp;
269
+
loop rest
270
+
| Incoming.Control_request ctrl_req ->
271
+
Log.info (fun m ->
272
+
m "Received control request (request_id: %s)"
273
+
ctrl_req.request_id);
274
+
handle_control_request t ctrl_req;
275
+
loop rest
276
+
| Incoming.Rate_limit_event ->
277
+
Log.debug (fun m -> m "Received rate_limit_event (ignored)");
278
+
loop rest)
279
+
and emit_responses responses rest =
280
+
match responses with
281
+
| [] -> loop rest
282
+
| r :: rs -> Seq.Cons (r, fun () -> emit_responses rs rest)
283
+
in
284
+
loop raw_seq
285
+
286
+
let register_hooks t ~options ~hook_callbacks ~next_callback_id =
287
+
let register_matcher event_name (pattern, callback) =
288
+
let callback_id = Fmt.str "hook_%d" !next_callback_id in
289
+
incr next_callback_id;
290
+
Hashtbl.add hook_callbacks callback_id callback;
291
+
Log.debug (fun m ->
292
+
m "Registered callback: %s for event: %s" callback_id event_name);
293
+
Hook_matcher_wire.{ matcher = pattern; hook_callback_ids = [ callback_id ] }
294
+
in
295
+
Options.hooks options
296
+
|> Option.iter (fun hooks_config ->
297
+
Log.info (fun m -> m "Registering hooks...");
298
+
let callbacks_by_event = Hooks.callbacks hooks_config in
299
+
let hooks_list =
300
+
List.map
301
+
(fun (event, matchers) ->
302
+
let event_name = Hooks.event_to_string event in
303
+
let matcher_wires =
304
+
List.map (register_matcher event_name) matchers
305
+
in
306
+
(event_name, Hook_matcher_wire.encode matcher_wires))
307
+
callbacks_by_event
308
+
in
309
+
let request = Control.Request.initialize ~hooks:hooks_list () in
310
+
let ctrl_req = Control.request ~request_id:"init_hooks" ~request () in
311
+
let initialize_msg =
312
+
Jsont.Json.encode Control.jsont ctrl_req
313
+
|> Err.ok ~msg:"Failed to encode initialize request: "
314
+
in
315
+
Log.info (fun m -> m "Sending hooks initialize request");
316
+
Transport.send t.transport initialize_msg)
317
+
318
+
let v ?(options = Options.default) ~sw ~process_mgr ~clock () =
319
+
(* Automatically enable permission prompt tool when callback is configured
320
+
(matching Python SDK behavior in client.py:104-121) *)
321
+
let options =
322
+
match Options.permission_callback options with
323
+
| Some _ when Options.permission_prompt_tool_name options = None ->
324
+
(* Set permission_prompt_tool_name to "stdio" to enable control protocol *)
325
+
Options.with_permission_prompt_tool_name "stdio" options
326
+
| _ -> options
327
+
in
328
+
let transport = Transport.v ~sw ~process_mgr ~options () in
329
+
330
+
(* Setup hook callbacks *)
331
+
let hook_callbacks = Hashtbl.create 16 in
332
+
let next_callback_id = ref 0 in
333
+
334
+
(* Setup MCP servers from options *)
335
+
let mcp_servers_ht = Hashtbl.create 16 in
336
+
List.iter
337
+
(fun (name, server) ->
338
+
Log.info (fun m -> m "Registering MCP server: %s" name);
339
+
Hashtbl.add mcp_servers_ht name server)
340
+
(Options.mcp_servers options);
341
+
342
+
let t =
343
+
{
344
+
transport;
345
+
permission_callback = Options.permission_callback options;
346
+
permission_log = None;
347
+
hook_callbacks;
348
+
session_id = None;
349
+
control_responses = Hashtbl.create 16;
350
+
control_mutex = Eio.Mutex.create ();
351
+
control_condition = Eio.Condition.create ();
352
+
clock;
353
+
responded_tool_ids = Hashtbl.create 16;
354
+
mcp_servers = mcp_servers_ht;
355
+
}
356
+
in
357
+
358
+
register_hooks t ~options ~hook_callbacks ~next_callback_id;
359
+
t
360
+
361
+
let send_message t msg =
362
+
Log.info (fun m -> m "-> %a" Message.pp msg);
363
+
let outgoing = Outgoing.Message msg in
364
+
let json = Outgoing.to_json outgoing in
365
+
Transport.send t.transport json
366
+
367
+
let query t prompt =
368
+
let msg = Message.user_string prompt in
369
+
send_message t msg
370
+
371
+
let respond_to_tool t ~tool_use_id ~content ?(is_error = false) () =
372
+
(* Check for duplicate response - prevents API errors from multiple responses *)
373
+
if Hashtbl.mem t.responded_tool_ids tool_use_id then begin
374
+
Log.warn (fun m ->
375
+
m "Skipping duplicate tool response for tool_use_id: %s" tool_use_id)
376
+
end
377
+
else begin
378
+
Hashtbl.add t.responded_tool_ids tool_use_id ();
379
+
let user_msg =
380
+
Message.User.with_tool_result ~tool_use_id ~content ~is_error ()
381
+
in
382
+
let msg = Message.User user_msg in
383
+
send_message t msg
384
+
end
385
+
386
+
let respond_to_tools t responses =
387
+
(* Filter out duplicates *)
388
+
let new_responses =
389
+
List.filter
390
+
(fun (tool_use_id, _, _) ->
391
+
if Hashtbl.mem t.responded_tool_ids tool_use_id then begin
392
+
Log.warn (fun m ->
393
+
m "Skipping duplicate tool response for tool_use_id: %s"
394
+
tool_use_id);
395
+
false
396
+
end
397
+
else begin
398
+
Hashtbl.add t.responded_tool_ids tool_use_id ();
399
+
true
400
+
end)
401
+
responses
402
+
in
403
+
if new_responses <> [] then begin
404
+
let tool_results =
405
+
List.map
406
+
(fun (tool_use_id, content, is_error_opt) ->
407
+
let is_error = Option.value is_error_opt ~default:false in
408
+
Content_block.tool_result ~tool_use_id ~content ~is_error ())
409
+
new_responses
410
+
in
411
+
let user_msg = Message.User.of_blocks tool_results in
412
+
let msg = Message.User user_msg in
413
+
send_message t msg
414
+
end
415
+
416
+
let clear_tool_response_tracking t = Hashtbl.clear t.responded_tool_ids
417
+
let receive t = fun () -> handle_messages t
418
+
419
+
let run t ~handler =
420
+
(* Stop after Complete response - don't wait for EOF since Claude CLI
421
+
waits for stdin to close before exiting, causing a deadlock *)
422
+
let rec loop seq =
423
+
match seq () with
424
+
| Seq.Nil -> ()
425
+
| Seq.Cons ((Response.Complete _ as resp), _) ->
426
+
Handler.dispatch handler resp
427
+
| Seq.Cons (resp, rest) ->
428
+
Handler.dispatch handler resp;
429
+
loop rest
430
+
in
431
+
loop (receive t)
432
+
433
+
let receive_all t =
434
+
let rec collect acc seq =
435
+
match seq () with
436
+
| Seq.Nil ->
437
+
Log.debug (fun m ->
438
+
m "End of response sequence (%d responses)" (List.length acc));
439
+
List.rev acc
440
+
| Seq.Cons ((Response.Complete _ as resp), _) ->
441
+
Log.debug (fun m -> m "Received final Complete response");
442
+
List.rev (resp :: acc)
443
+
| Seq.Cons (resp, rest) -> collect (resp :: acc) rest
444
+
in
445
+
collect [] (receive t)
446
+
447
+
let interrupt t = Transport.interrupt t.transport
448
+
449
+
let enable_permission_discovery t =
450
+
let log = ref [] in
451
+
let callback = Permissions.discovery log in
452
+
t.permission_callback <- Some callback;
453
+
t.permission_log <- Some log
454
+
455
+
let discovered_permissions t =
456
+
t.permission_log |> Option.map ( ! ) |> Option.value ~default:[]
457
+
458
+
let decode_control_response response_json =
459
+
(* Parse the response - extract the "response" field using jsont codec *)
460
+
let response_field_codec =
461
+
Jsont.Object.map ~kind:"ResponseField" Fun.id
462
+
|> Jsont.Object.mem "response" Jsont.json ~enc:Fun.id
463
+
|> Jsont.Object.finish
464
+
in
465
+
let response_data =
466
+
Jsont.Json.decode response_field_codec response_json
467
+
|> Err.ok' ~msg:"Failed to extract response field: "
468
+
in
469
+
let response =
470
+
Jsont.Json.decode Control.Response.jsont response_data
471
+
|> Err.ok' ~msg:"Failed to decode response: "
472
+
in
473
+
match response with
474
+
| Control.Response.Success s -> s.response
475
+
| Control.Response.Error e ->
476
+
raise
477
+
(Failure
478
+
(Fmt.str "Control request failed: [%d] %s" e.error.code
479
+
e.error.message))
480
+
481
+
(* Helper to send a control request and wait for response *)
482
+
let send_control_request t ~request_id request =
483
+
(* Send the control request *)
484
+
let control_msg = Control.request ~request_id ~request () in
485
+
let json =
486
+
Jsont.Json.encode Control.jsont control_msg
487
+
|> Err.ok ~msg:"Failed to encode control request: "
488
+
in
489
+
Log.info (fun m -> m "Sending control request: %s" (json_to_string json));
490
+
Transport.send t.transport json;
491
+
492
+
(* Wait for the response with timeout *)
493
+
let max_wait = 10.0 in
494
+
(* 10 seconds timeout *)
495
+
let start_time = Eio.Time.now t.clock in
496
+
497
+
let rec wait_for_response () =
498
+
Eio.Mutex.use_rw ~protect:false t.control_mutex (fun () ->
499
+
match Hashtbl.find_opt t.control_responses request_id with
500
+
| Some response_json ->
501
+
(* Remove it from the table *)
502
+
Hashtbl.remove t.control_responses request_id;
503
+
response_json
504
+
| None ->
505
+
let elapsed = Eio.Time.now t.clock -. start_time in
506
+
if elapsed > max_wait then
507
+
raise
508
+
(Failure
509
+
(Fmt.str "Timeout waiting for control response: %s"
510
+
request_id))
511
+
else (
512
+
(* Release mutex and wait for signal *)
513
+
Eio.Condition.await_no_mutex t.control_condition;
514
+
wait_for_response ()))
515
+
in
516
+
517
+
let response_json = wait_for_response () in
518
+
Log.debug (fun m ->
519
+
m "Received control response: %s" (json_to_string response_json));
520
+
decode_control_response response_json
521
+
522
+
let set_permission_mode t mode =
523
+
let request_id = Fmt.str "set_perm_mode_%f" (Eio.Time.now t.clock) in
524
+
let request = Control.Request.set_permission_mode ~mode () in
525
+
let _response = send_control_request t ~request_id request in
526
+
Log.info (fun m ->
527
+
m "Permission mode set to: %s" (Permissions.Mode.to_string mode))
528
+
529
+
let set_model t model =
530
+
let model_str = Model.to_string model in
531
+
let request_id = Fmt.str "set_model_%f" (Eio.Time.now t.clock) in
532
+
let request = Control.Request.set_model ~model:model_str () in
533
+
let _response = send_control_request t ~request_id request in
534
+
Log.info (fun m -> m "Model set to: %s" model_str)
535
+
536
+
let server_info t =
537
+
let request_id = Fmt.str "get_server_info_%f" (Eio.Time.now t.clock) in
538
+
let request = Control.Request.get_server_info () in
539
+
let response_data =
540
+
send_control_request t ~request_id request
541
+
|> Option.to_result ~none:"No response data from get_server_info request"
542
+
|> Err.ok ~msg:""
543
+
in
544
+
let server_info =
545
+
Jsont.Json.decode Control.Server_info.jsont response_data
546
+
|> Err.ok' ~msg:"Failed to decode server info: "
547
+
in
548
+
Log.info (fun m ->
549
+
m "Retrieved server info: %a"
550
+
(Jsont.pp_value Control.Server_info.jsont ())
551
+
server_info);
552
+
Server_info.of_control server_info
553
+
554
+
module Advanced = struct
555
+
let send_message t msg = send_message t msg
556
+
557
+
let send_user_message t user_msg =
558
+
let msg = Message.User user_msg in
559
+
send_message t msg
560
+
561
+
let send_raw t control =
562
+
let json =
563
+
Jsont.Json.encode Control.jsont control
564
+
|> Err.ok ~msg:"Failed to encode control message: "
565
+
in
566
+
Log.info (fun m -> m "→ Raw control: %s" (json_to_string json));
567
+
Transport.send t.transport json
568
+
569
+
let send_json t json =
570
+
Log.info (fun m -> m "→ Raw JSON: %s" (json_to_string json));
571
+
Transport.send t.transport json
572
+
573
+
let receive_raw t = handle_raw_messages t
574
+
end
+323
lib/client.mli
+323
lib/client.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Client interface for interacting with Claude.
7
+
8
+
This module provides the high-level client API for sending messages to
9
+
Claude and receiving responses. It handles the bidirectional streaming
10
+
protocol, permission callbacks, and hooks.
11
+
12
+
{2 Basic Usage}
13
+
14
+
{[
15
+
Eio.Switch.run @@ fun sw ->
16
+
let client = Client.v ~sw ~process_mgr ~clock () in
17
+
Client.query client "What is 2+2?";
18
+
19
+
let messages = Client.receive_all client in
20
+
List.iter
21
+
(function
22
+
| Message.Assistant msg ->
23
+
Printf.printf "Claude: %s\n" (Message.Assistant.text msg)
24
+
| _ -> ())
25
+
messages
26
+
]}
27
+
28
+
{2 Features}
29
+
30
+
- {b Message Streaming}: Messages are streamed lazily via {!Seq.t}
31
+
- {b Permission Control}: Custom permission callbacks for tool usage
32
+
- {b Hooks}: Intercept and modify tool execution
33
+
- {b Dynamic Control}: Change settings mid-conversation
34
+
- {b Resource Management}: Automatic cleanup via Eio switches
35
+
36
+
{2 Message Flow}
37
+
38
+
1. Create a client with {!v} 2. Send messages with {!query} or
39
+
{!Advanced.send_message} 3. Receive responses with {!receive} or
40
+
{!receive_all} 4. Continue multi-turn conversations by sending more messages
41
+
5. Client automatically cleans up when the switch exits
42
+
43
+
{2 Advanced Features}
44
+
45
+
- Permission discovery mode for understanding required permissions
46
+
- Mid-conversation model switching and permission mode changes
47
+
- Server capability introspection *)
48
+
49
+
val src : Logs.Src.t
50
+
(** The log source for client operations. *)
51
+
52
+
type t
53
+
(** The type of Claude clients. *)
54
+
55
+
val session_id : t -> string option
56
+
(** [session_id t] returns the session ID if one has been received from Claude.
57
+
The session ID is provided in system init messages and uniquely identifies
58
+
the current conversation session. *)
59
+
60
+
val v :
61
+
?options:Options.t ->
62
+
sw:Eio.Switch.t ->
63
+
process_mgr:_ Eio.Process.mgr ->
64
+
clock:float Eio.Time.clock_ty Eio.Resource.t ->
65
+
unit ->
66
+
t
67
+
(** [v ?options ~sw ~process_mgr ~clock ()] creates a new Claude client.
68
+
69
+
@param options Configuration options (defaults to {!Options.default})
70
+
@param sw Eio switch for resource management
71
+
@param process_mgr Eio process manager for spawning the Claude CLI
72
+
@param clock Eio clock for time operations. *)
73
+
74
+
(** {1 Simple Query Interface} *)
75
+
76
+
val query : t -> string -> unit
77
+
(** [query t prompt] sends a text message to Claude.
78
+
79
+
This is a convenience function for simple string messages. For more complex
80
+
messages with tool results or multiple content blocks, use
81
+
{!Advanced.send_message} instead. *)
82
+
83
+
val respond_to_tool :
84
+
t ->
85
+
tool_use_id:string ->
86
+
content:Jsont.json ->
87
+
?is_error:bool ->
88
+
unit ->
89
+
unit
90
+
(** [respond_to_tool t ~tool_use_id ~content ?is_error ()] responds to a tool
91
+
use request.
92
+
93
+
{b Duplicate protection:} If the same [tool_use_id] has already been
94
+
responded to, this call is silently skipped with a warning log. This
95
+
prevents API errors from duplicate tool responses.
96
+
97
+
@param tool_use_id The ID from the {!Response.Tool_use.t} event
98
+
@param content
99
+
The result content (can be a string or array of content blocks)
100
+
@param is_error Whether this is an error response (default: false). *)
101
+
102
+
val respond_to_tools : t -> (string * Jsont.json * bool option) list -> unit
103
+
(** [respond_to_tools t responses] responds to multiple tool use requests at
104
+
once.
105
+
106
+
{b Duplicate protection:} Any [tool_use_id] that has already been responded
107
+
to is filtered out with a warning log.
108
+
109
+
Each tuple is [(tool_use_id, content, is_error option)] where content can be
110
+
a string or array of content blocks.
111
+
112
+
Example:
113
+
{[
114
+
Client.respond_to_tools client
115
+
[
116
+
("tool_use_123", Jsont.string "Success", None);
117
+
("tool_use_456", Jsont.string "Error occurred", Some true);
118
+
]
119
+
]} *)
120
+
121
+
val clear_tool_response_tracking : t -> unit
122
+
(** [clear_tool_response_tracking t] clears the internal tracking of which
123
+
tool_use_ids have been responded to.
124
+
125
+
This is useful when starting a new conversation or turn where you want to
126
+
allow responses to previously-seen tool IDs. Normally this is not needed as
127
+
tool IDs are unique per conversation turn. *)
128
+
129
+
(** {1 Response Handling} *)
130
+
131
+
val run : t -> handler:#Handler.handler -> unit
132
+
(** [run t ~handler] processes all responses using the given handler.
133
+
134
+
This is the recommended way to handle responses in an event-driven style.
135
+
The handler's methods will be called for each response event as it arrives.
136
+
137
+
Example:
138
+
{[
139
+
let my_handler =
140
+
object
141
+
inherit Claude.Handler.default
142
+
method! on_text t = print_endline (Response.Text.content t)
143
+
144
+
method! on_complete c =
145
+
Printf.printf "Cost: $%.4f\n"
146
+
(Option.value ~default:0.0 (Response.Complete.total_cost_usd c))
147
+
end
148
+
in
149
+
Client.query client "Hello";
150
+
Client.run client ~handler:my_handler
151
+
]} *)
152
+
153
+
val receive : t -> Response.t Seq.t
154
+
(** [receive t] returns a lazy sequence of responses from Claude.
155
+
156
+
The sequence yields response events as they arrive from Claude, including:
157
+
- {!constructor:Response.Text} - Text content from assistant
158
+
- {!constructor:Response.Tool_use} - Tool invocation requests
159
+
- {!constructor:Response.Thinking} - Internal reasoning
160
+
- {!constructor:Response.Init} - Session initialization
161
+
- {!constructor:Response.Error} - Error events
162
+
- {!constructor:Response.Complete} - Final result with usage statistics
163
+
164
+
Control messages (permission requests, hook callbacks) are handled
165
+
internally and not yielded to the sequence.
166
+
167
+
For simple cases, prefer {!run} with a handler instead. *)
168
+
169
+
val receive_all : t -> Response.t list
170
+
(** [receive_all t] collects all responses into a list.
171
+
172
+
This is a convenience function that consumes the {!receive} sequence. Use
173
+
this when you want to process all responses at once rather than streaming
174
+
them.
175
+
176
+
For most cases, prefer {!run} with a handler instead. *)
177
+
178
+
val interrupt : t -> unit
179
+
(** [interrupt t] sends an interrupt signal to stop Claude's execution. *)
180
+
181
+
(** {1 Dynamic Control}
182
+
183
+
These methods allow you to change Claude's behavior mid-conversation without
184
+
recreating the client. This is useful for:
185
+
186
+
- Adjusting permission strictness based on user feedback
187
+
- Switching to faster/cheaper models for simple tasks
188
+
- Adapting to changing requirements during long conversations
189
+
- Introspecting server capabilities
190
+
191
+
{2 Example: Adaptive Permission Control}
192
+
193
+
{[
194
+
(* Start with strict permissions *)
195
+
let client = Client.v ~sw ~process_mgr ~clock
196
+
~options:(Options.default
197
+
|> Options.with_permission_mode Permissions.Mode.Default) ()
198
+
in
199
+
200
+
Client.query client "Analyze this code";
201
+
let _ = Client.receive_all client in
202
+
203
+
(* User approves, switch to auto-accept edits *)
204
+
Client.set_permission_mode client Permissions.Mode.Accept_edits;
205
+
206
+
Client.query client "Now refactor it";
207
+
let _ = Client.receive_all client in
208
+
]}
209
+
210
+
{2 Example: Model Switching for Efficiency}
211
+
212
+
{[
213
+
(* Use powerful model for complex analysis *)
214
+
let client = Client.v ~sw ~process_mgr ~clock
215
+
~options:(Options.default |> Options.with_model "claude-sonnet-4-5") ()
216
+
in
217
+
218
+
Client.query client "Design a new architecture for this system";
219
+
let _ = Client.receive_all client in
220
+
221
+
(* Switch to faster model for simple tasks *)
222
+
Client.set_model client "claude-haiku-4";
223
+
224
+
Client.query client "Now write a README";
225
+
let _ = Client.receive_all client in
226
+
]}
227
+
228
+
{2 Example: Server Introspection}
229
+
230
+
{[
231
+
let info = Client.server_info client in
232
+
Printf.printf "Claude CLI version: %s\n" (Control.Server_info.version info);
233
+
Printf.printf "Capabilities: %s\n"
234
+
(String.concat ", " (Control.Server_info.capabilities info))
235
+
]} *)
236
+
237
+
val set_permission_mode : t -> Permissions.Mode.t -> unit
238
+
(** [set_permission_mode t mode] changes the permission mode mid-conversation.
239
+
240
+
This allows switching between permission modes without recreating the
241
+
client:
242
+
- {!Permissions.Mode.Default} - Prompt for all permissions
243
+
- {!Permissions.Mode.Accept_edits} - Auto-accept file edits
244
+
- {!Permissions.Mode.Plan} - Planning mode with restricted execution
245
+
- {!Permissions.Mode.Bypass_permissions} - Skip all permission checks.
246
+
247
+
@raise Failure if the server returns an error. *)
248
+
249
+
val set_model : t -> Model.t -> unit
250
+
(** [set_model t model] switches to a different AI model mid-conversation.
251
+
252
+
Common models:
253
+
- [`Sonnet_4_5] - Most capable, balanced performance
254
+
- [`Opus_4] - Maximum capability for complex tasks
255
+
- [`Haiku_4] - Fast and cost-effective
256
+
257
+
@raise Failure if the model is invalid or unavailable. *)
258
+
259
+
val server_info : t -> Server_info.t
260
+
(** [server_info t] retrieves server capabilities and metadata.
261
+
262
+
Returns information about:
263
+
- Server version string
264
+
- Available capabilities
265
+
- Supported commands
266
+
- Available output styles
267
+
268
+
Useful for feature detection and debugging.
269
+
270
+
@raise Failure if the server returns an error. *)
271
+
272
+
(** {1 Permission Discovery} *)
273
+
274
+
val enable_permission_discovery : t -> unit
275
+
(** [enable_permission_discovery t] enables permission discovery mode.
276
+
277
+
In discovery mode, all tool usage is logged but allowed. Use
278
+
{!discovered_permissions} to retrieve the list of permissions that were
279
+
requested during execution.
280
+
281
+
This is useful for understanding what permissions your prompt requires. *)
282
+
283
+
val discovered_permissions : t -> Permissions.Rule.t list
284
+
(** [discovered_permissions t] returns permissions discovered during execution.
285
+
286
+
Only useful after enabling {!enable_permission_discovery}. *)
287
+
288
+
(** {1 Advanced Interface}
289
+
290
+
Low-level access to the protocol for advanced use cases. *)
291
+
292
+
module Advanced : sig
293
+
val send_message : t -> Message.t -> unit
294
+
(** [send_message t msg] sends a message to Claude.
295
+
296
+
Supports all message types including user messages with tool results. *)
297
+
298
+
val send_user_message : t -> Message.User.t -> unit
299
+
(** [send_user_message t msg] sends a user message to Claude. *)
300
+
301
+
val send_raw : t -> Control.t -> unit
302
+
(** [send_raw t control] sends a raw SDK control message.
303
+
304
+
This is for advanced use cases that need direct control protocol access.
305
+
*)
306
+
307
+
val send_json : t -> Jsont.json -> unit
308
+
(** [send_json t json] sends raw JSON to Claude.
309
+
310
+
This is the lowest-level send operation. Use with caution. *)
311
+
312
+
val receive_raw : t -> Incoming.t Seq.t
313
+
(** [receive_raw t] returns a lazy sequence of raw incoming messages.
314
+
315
+
This includes all message types before Response conversion:
316
+
- {!Incoming.t.constructor-Message} - Regular messages
317
+
- {!Incoming.t.constructor-Control_response} - Control responses (normally
318
+
handled internally)
319
+
- {!Incoming.t.constructor-Control_request} - Control requests (normally
320
+
handled internally)
321
+
322
+
Most users should use {!receive} or {!run} instead. *)
323
+
end
+147
lib/content_block.ml
+147
lib/content_block.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let src = Logs.Src.create "claude.content_block" ~doc:"Claude content blocks"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
module Text = struct
11
+
type t = { text : string; unknown : Unknown.t }
12
+
13
+
let create text = { text; unknown = Unknown.empty }
14
+
let make text unknown = { text; unknown }
15
+
let text t = t.text
16
+
let unknown t = t.unknown
17
+
18
+
let jsont : t Jsont.t =
19
+
Jsont.Object.map ~kind:"Text" make
20
+
|> Jsont.Object.mem "text" Jsont.string ~enc:text
21
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
22
+
|> Jsont.Object.finish
23
+
end
24
+
25
+
module Tool_use = struct
26
+
type t = {
27
+
id : string;
28
+
name : string;
29
+
input : Jsont.json;
30
+
unknown : Unknown.t;
31
+
}
32
+
33
+
let create ~id ~name ~input = { id; name; input; unknown = Unknown.empty }
34
+
let make id name input unknown = { id; name; input; unknown }
35
+
let id t = t.id
36
+
let name t = t.name
37
+
let input t = Tool_input.of_json t.input
38
+
let unknown t = t.unknown
39
+
40
+
let jsont : t Jsont.t =
41
+
Jsont.Object.map ~kind:"Tool_use" make
42
+
|> Jsont.Object.mem "id" Jsont.string ~enc:id
43
+
|> Jsont.Object.mem "name" Jsont.string ~enc:name
44
+
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun t -> t.input)
45
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
46
+
|> Jsont.Object.finish
47
+
end
48
+
49
+
module Tool_result = struct
50
+
type t = {
51
+
tool_use_id : string;
52
+
content : Jsont.json option;
53
+
is_error : bool option;
54
+
unknown : Unknown.t;
55
+
}
56
+
57
+
let create ~tool_use_id ?content ?is_error () =
58
+
{ tool_use_id; content; is_error; unknown = Unknown.empty }
59
+
60
+
let make tool_use_id content is_error unknown =
61
+
{ tool_use_id; content; is_error; unknown }
62
+
63
+
let tool_use_id t = t.tool_use_id
64
+
let content t = t.content
65
+
let is_error t = t.is_error
66
+
let unknown t = t.unknown
67
+
68
+
let jsont : t Jsont.t =
69
+
Jsont.Object.map ~kind:"Tool_result" make
70
+
|> Jsont.Object.mem "tool_use_id" Jsont.string ~enc:tool_use_id
71
+
|> Jsont.Object.opt_mem "content" Jsont.json ~enc:content
72
+
|> Jsont.Object.opt_mem "is_error" Jsont.bool ~enc:is_error
73
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
74
+
|> Jsont.Object.finish
75
+
end
76
+
77
+
module Thinking = struct
78
+
type t = { thinking : string; signature : string; unknown : Unknown.t }
79
+
80
+
let create ~thinking ~signature =
81
+
{ thinking; signature; unknown = Unknown.empty }
82
+
83
+
let make thinking signature unknown = { thinking; signature; unknown }
84
+
let thinking t = t.thinking
85
+
let signature t = t.signature
86
+
let unknown t = t.unknown
87
+
88
+
let jsont : t Jsont.t =
89
+
Jsont.Object.map ~kind:"Thinking" make
90
+
|> Jsont.Object.mem "thinking" Jsont.string ~enc:thinking
91
+
|> Jsont.Object.mem "signature" Jsont.string ~enc:signature
92
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
93
+
|> Jsont.Object.finish
94
+
end
95
+
96
+
type t =
97
+
| Text of Text.t
98
+
| Tool_use of Tool_use.t
99
+
| Tool_result of Tool_result.t
100
+
| Thinking of Thinking.t
101
+
102
+
let text s = Text (Text.create s)
103
+
104
+
let tool_use ~id ~name ~input =
105
+
Tool_use (Tool_use.create ~id ~name ~input:(Tool_input.to_json input))
106
+
107
+
let tool_result ~tool_use_id ?content ?is_error () =
108
+
Tool_result (Tool_result.create ~tool_use_id ?content ?is_error ())
109
+
110
+
let thinking ~thinking ~signature =
111
+
Thinking (Thinking.create ~thinking ~signature)
112
+
113
+
let jsont : t Jsont.t =
114
+
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
115
+
let case_text = case_map "text" Text.jsont (fun v -> Text v) in
116
+
let case_tool_use =
117
+
case_map "tool_use" Tool_use.jsont (fun v -> Tool_use v)
118
+
in
119
+
let case_tool_result =
120
+
case_map "tool_result" Tool_result.jsont (fun v -> Tool_result v)
121
+
in
122
+
let case_thinking =
123
+
case_map "thinking" Thinking.jsont (fun v -> Thinking v)
124
+
in
125
+
let enc_case = function
126
+
| Text v -> Jsont.Object.Case.value case_text v
127
+
| Tool_use v -> Jsont.Object.Case.value case_tool_use v
128
+
| Tool_result v -> Jsont.Object.Case.value case_tool_result v
129
+
| Thinking v -> Jsont.Object.Case.value case_thinking v
130
+
in
131
+
let cases =
132
+
Jsont.Object.Case.
133
+
[
134
+
make case_text;
135
+
make case_tool_use;
136
+
make case_tool_result;
137
+
make case_thinking;
138
+
]
139
+
in
140
+
Jsont.Object.map ~kind:"Content_block" Fun.id
141
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
142
+
~tag_to_string:Fun.id ~tag_compare:String.compare
143
+
|> Jsont.Object.finish
144
+
145
+
let pp ppf t = Jsont.pp_value jsont () ppf t
146
+
let log_received t = Log.debug (fun m -> m "Received content block: %a" pp t)
147
+
let log_sending t = Log.debug (fun m -> m "Sending content block: %a" pp t)
+89
lib/content_block.mli
+89
lib/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 in messages. *)
7
+
8
+
val src : Logs.Src.t
9
+
(** Log source for content block operations. *)
10
+
11
+
(** {1 Text Blocks} *)
12
+
13
+
module Text : sig
14
+
type t
15
+
16
+
val create : string -> t
17
+
val text : t -> string
18
+
val unknown : t -> Unknown.t
19
+
val jsont : t Jsont.t
20
+
end
21
+
22
+
(** {1 Tool Use Blocks} *)
23
+
24
+
module Tool_use : sig
25
+
type t
26
+
27
+
val create : id:string -> name:string -> input:Jsont.json -> t
28
+
val id : t -> string
29
+
val name : t -> string
30
+
31
+
val input : t -> Tool_input.t
32
+
(** [input t] returns the tool input as a typed {!Tool_input.t}. *)
33
+
34
+
val unknown : t -> Unknown.t
35
+
val jsont : t Jsont.t
36
+
end
37
+
38
+
(** {1 Tool Result Blocks} *)
39
+
40
+
module Tool_result : sig
41
+
type t
42
+
43
+
val create :
44
+
tool_use_id:string -> ?content:Jsont.json -> ?is_error:bool -> unit -> t
45
+
46
+
val tool_use_id : t -> string
47
+
val content : t -> Jsont.json option
48
+
val is_error : t -> bool option
49
+
val unknown : t -> Unknown.t
50
+
val jsont : t Jsont.t
51
+
end
52
+
53
+
(** {1 Thinking Blocks} *)
54
+
55
+
module Thinking : sig
56
+
type t
57
+
58
+
val create : thinking:string -> signature:string -> t
59
+
val thinking : t -> string
60
+
val signature : t -> string
61
+
val unknown : t -> Unknown.t
62
+
val jsont : t Jsont.t
63
+
end
64
+
65
+
(** {1 Content Block Union Type} *)
66
+
67
+
type t =
68
+
| Text of Text.t
69
+
| Tool_use of Tool_use.t
70
+
| Tool_result of Tool_result.t
71
+
| Thinking of Thinking.t
72
+
73
+
val pp : Format.formatter -> t -> unit
74
+
75
+
(** {1 Constructors} *)
76
+
77
+
val text : string -> t
78
+
val tool_use : id:string -> name:string -> input:Tool_input.t -> t
79
+
80
+
val tool_result :
81
+
tool_use_id:string -> ?content:Jsont.json -> ?is_error:bool -> unit -> t
82
+
83
+
val thinking : thinking:string -> signature:string -> t
84
+
val jsont : t Jsont.t
85
+
86
+
(** {1 Logging} *)
87
+
88
+
val log_received : t -> unit
89
+
val log_sending : t -> unit
+516
lib/control.ml
+516
lib/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 = Logs.Src.create "claude.control" ~doc:"Claude control protocol"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
module Request = struct
11
+
type interrupt = { subtype : [ `Interrupt ]; unknown : Unknown.t }
12
+
13
+
type permission = {
14
+
subtype : [ `Can_use_tool ];
15
+
tool_name : string;
16
+
input : Jsont.json;
17
+
permission_suggestions : Permissions.Update.t list option;
18
+
blocked_path : string option;
19
+
unknown : Unknown.t;
20
+
}
21
+
22
+
type initialize = {
23
+
subtype : [ `Initialize ];
24
+
hooks : (string * Jsont.json) list option;
25
+
unknown : Unknown.t;
26
+
}
27
+
28
+
type set_permission_mode = {
29
+
subtype : [ `Set_permission_mode ];
30
+
mode : Permissions.Mode.t;
31
+
unknown : Unknown.t;
32
+
}
33
+
34
+
type hook_callback = {
35
+
subtype : [ `Hook_callback ];
36
+
callback_id : string;
37
+
input : Jsont.json;
38
+
tool_use_id : string option;
39
+
unknown : Unknown.t;
40
+
}
41
+
42
+
type mcp_message = {
43
+
subtype : [ `Mcp_message ];
44
+
server_name : string;
45
+
message : Jsont.json;
46
+
unknown : Unknown.t;
47
+
}
48
+
49
+
type set_model = {
50
+
subtype : [ `Set_model ];
51
+
model : string;
52
+
unknown : Unknown.t;
53
+
}
54
+
55
+
type get_server_info = { subtype : [ `Get_server_info ]; unknown : Unknown.t }
56
+
57
+
type t =
58
+
| Interrupt of interrupt
59
+
| Permission of permission
60
+
| Initialize of initialize
61
+
| Set_permission_mode of set_permission_mode
62
+
| Hook_callback of hook_callback
63
+
| Mcp_message of mcp_message
64
+
| Set_model of set_model
65
+
| Get_server_info of get_server_info
66
+
67
+
let interrupt ?(unknown = Unknown.empty) () =
68
+
Interrupt { subtype = `Interrupt; unknown }
69
+
70
+
let permission ~tool_name ~input ?permission_suggestions ?blocked_path
71
+
?(unknown = Unknown.empty) () =
72
+
Permission
73
+
{
74
+
subtype = `Can_use_tool;
75
+
tool_name;
76
+
input;
77
+
permission_suggestions;
78
+
blocked_path;
79
+
unknown;
80
+
}
81
+
82
+
let initialize ?hooks ?(unknown = Unknown.empty) () =
83
+
Initialize { subtype = `Initialize; hooks; unknown }
84
+
85
+
let set_permission_mode ~mode ?(unknown = Unknown.empty) () =
86
+
Set_permission_mode { subtype = `Set_permission_mode; mode; unknown }
87
+
88
+
let hook_callback ~callback_id ~input ?tool_use_id ?(unknown = Unknown.empty)
89
+
() =
90
+
Hook_callback
91
+
{ subtype = `Hook_callback; callback_id; input; tool_use_id; unknown }
92
+
93
+
let mcp_message ~server_name ~message ?(unknown = Unknown.empty) () =
94
+
Mcp_message { subtype = `Mcp_message; server_name; message; unknown }
95
+
96
+
let set_model ~model ?(unknown = Unknown.empty) () =
97
+
Set_model { subtype = `Set_model; model; unknown }
98
+
99
+
let get_server_info ?(unknown = Unknown.empty) () =
100
+
Get_server_info { subtype = `Get_server_info; unknown }
101
+
102
+
(* Individual record codecs *)
103
+
let interrupt_jsont : interrupt Jsont.t =
104
+
let make (unknown : Unknown.t) : interrupt =
105
+
{ subtype = `Interrupt; unknown }
106
+
in
107
+
Jsont.Object.map ~kind:"Interrupt" make
108
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : interrupt) ->
109
+
r.unknown)
110
+
|> Jsont.Object.finish
111
+
112
+
let permission_jsont : permission Jsont.t =
113
+
let make tool_name input permission_suggestions blocked_path
114
+
(unknown : Unknown.t) : permission =
115
+
{
116
+
subtype = `Can_use_tool;
117
+
tool_name;
118
+
input;
119
+
permission_suggestions;
120
+
blocked_path;
121
+
unknown;
122
+
}
123
+
in
124
+
Jsont.Object.map ~kind:"Permission" make
125
+
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:(fun (r : permission) ->
126
+
r.tool_name)
127
+
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : permission) ->
128
+
r.input)
129
+
|> Jsont.Object.opt_mem "permission_suggestions"
130
+
(Jsont.list Permissions.Update.jsont) ~enc:(fun (r : permission) ->
131
+
r.permission_suggestions)
132
+
|> Jsont.Object.opt_mem "blocked_path" Jsont.string
133
+
~enc:(fun (r : permission) -> r.blocked_path)
134
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : permission) ->
135
+
r.unknown)
136
+
|> Jsont.Object.finish
137
+
138
+
let initialize_jsont : initialize Jsont.t =
139
+
(* The hooks field is an object with string keys and json values *)
140
+
let hooks_map_jsont = Jsont.Object.as_string_map Jsont.json in
141
+
let module StringMap = Map.Make (String) in
142
+
let hooks_jsont =
143
+
Jsont.map
144
+
~dec:(fun m -> StringMap.bindings m)
145
+
~enc:(fun l -> StringMap.of_seq (List.to_seq l))
146
+
hooks_map_jsont
147
+
in
148
+
let make hooks (unknown : Unknown.t) : initialize =
149
+
{ subtype = `Initialize; hooks; unknown }
150
+
in
151
+
Jsont.Object.map ~kind:"Initialize" make
152
+
|> Jsont.Object.opt_mem "hooks" hooks_jsont ~enc:(fun (r : initialize) ->
153
+
r.hooks)
154
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : initialize) ->
155
+
r.unknown)
156
+
|> Jsont.Object.finish
157
+
158
+
let set_permission_mode_jsont : set_permission_mode Jsont.t =
159
+
let make mode (unknown : Unknown.t) : set_permission_mode =
160
+
{ subtype = `Set_permission_mode; mode; unknown }
161
+
in
162
+
Jsont.Object.map ~kind:"SetPermissionMode" make
163
+
|> Jsont.Object.mem "mode" Permissions.Mode.jsont
164
+
~enc:(fun (r : set_permission_mode) -> r.mode)
165
+
|> Jsont.Object.keep_unknown Unknown.mems
166
+
~enc:(fun (r : set_permission_mode) -> r.unknown)
167
+
|> Jsont.Object.finish
168
+
169
+
let hook_callback_jsont : hook_callback Jsont.t =
170
+
let make callback_id input tool_use_id (unknown : Unknown.t) : hook_callback
171
+
=
172
+
{ subtype = `Hook_callback; callback_id; input; tool_use_id; unknown }
173
+
in
174
+
Jsont.Object.map ~kind:"HookCallback" make
175
+
|> Jsont.Object.mem "callback_id" Jsont.string
176
+
~enc:(fun (r : hook_callback) -> r.callback_id)
177
+
|> Jsont.Object.mem "input" Jsont.json ~enc:(fun (r : hook_callback) ->
178
+
r.input)
179
+
|> Jsont.Object.opt_mem "tool_use_id" Jsont.string
180
+
~enc:(fun (r : hook_callback) -> r.tool_use_id)
181
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : hook_callback) ->
182
+
r.unknown)
183
+
|> Jsont.Object.finish
184
+
185
+
let mcp_message_jsont : mcp_message Jsont.t =
186
+
let make server_name message (unknown : Unknown.t) : mcp_message =
187
+
{ subtype = `Mcp_message; server_name; message; unknown }
188
+
in
189
+
Jsont.Object.map ~kind:"McpMessage" make
190
+
|> Jsont.Object.mem "server_name" Jsont.string
191
+
~enc:(fun (r : mcp_message) -> r.server_name)
192
+
|> Jsont.Object.mem "message" Jsont.json ~enc:(fun (r : mcp_message) ->
193
+
r.message)
194
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : mcp_message) ->
195
+
r.unknown)
196
+
|> Jsont.Object.finish
197
+
198
+
let set_model_jsont : set_model Jsont.t =
199
+
let make model (unknown : Unknown.t) : set_model =
200
+
{ subtype = `Set_model; model; unknown }
201
+
in
202
+
Jsont.Object.map ~kind:"SetModel" make
203
+
|> Jsont.Object.mem "model" Jsont.string ~enc:(fun (r : set_model) ->
204
+
r.model)
205
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : set_model) ->
206
+
r.unknown)
207
+
|> Jsont.Object.finish
208
+
209
+
let get_server_info_jsont : get_server_info Jsont.t =
210
+
let make (unknown : Unknown.t) : get_server_info =
211
+
{ subtype = `Get_server_info; unknown }
212
+
in
213
+
Jsont.Object.map ~kind:"GetServerInfo" make
214
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : get_server_info) ->
215
+
r.unknown)
216
+
|> Jsont.Object.finish
217
+
218
+
(* Main variant codec using subtype discriminator *)
219
+
let jsont : t Jsont.t =
220
+
let case_interrupt =
221
+
Jsont.Object.Case.map "interrupt" interrupt_jsont ~dec:(fun v ->
222
+
Interrupt v)
223
+
in
224
+
let case_permission =
225
+
Jsont.Object.Case.map "can_use_tool" permission_jsont ~dec:(fun v ->
226
+
Permission v)
227
+
in
228
+
let case_initialize =
229
+
Jsont.Object.Case.map "initialize" initialize_jsont ~dec:(fun v ->
230
+
Initialize v)
231
+
in
232
+
let case_set_permission_mode =
233
+
Jsont.Object.Case.map "set_permission_mode" set_permission_mode_jsont
234
+
~dec:(fun v -> Set_permission_mode v)
235
+
in
236
+
let case_hook_callback =
237
+
Jsont.Object.Case.map "hook_callback" hook_callback_jsont ~dec:(fun v ->
238
+
Hook_callback v)
239
+
in
240
+
let case_mcp_message =
241
+
Jsont.Object.Case.map "mcp_message" mcp_message_jsont ~dec:(fun v ->
242
+
Mcp_message v)
243
+
in
244
+
let case_set_model =
245
+
Jsont.Object.Case.map "set_model" set_model_jsont ~dec:(fun v ->
246
+
Set_model v)
247
+
in
248
+
let case_get_server_info =
249
+
Jsont.Object.Case.map "get_server_info" get_server_info_jsont
250
+
~dec:(fun v -> Get_server_info v)
251
+
in
252
+
253
+
let enc_case = function
254
+
| Interrupt v -> Jsont.Object.Case.value case_interrupt v
255
+
| Permission v -> Jsont.Object.Case.value case_permission v
256
+
| Initialize v -> Jsont.Object.Case.value case_initialize v
257
+
| Set_permission_mode v ->
258
+
Jsont.Object.Case.value case_set_permission_mode v
259
+
| Hook_callback v -> Jsont.Object.Case.value case_hook_callback v
260
+
| Mcp_message v -> Jsont.Object.Case.value case_mcp_message v
261
+
| Set_model v -> Jsont.Object.Case.value case_set_model v
262
+
| Get_server_info v -> Jsont.Object.Case.value case_get_server_info v
263
+
in
264
+
265
+
let cases =
266
+
Jsont.Object.Case.
267
+
[
268
+
make case_interrupt;
269
+
make case_permission;
270
+
make case_initialize;
271
+
make case_set_permission_mode;
272
+
make case_hook_callback;
273
+
make case_mcp_message;
274
+
make case_set_model;
275
+
make case_get_server_info;
276
+
]
277
+
in
278
+
279
+
Jsont.Object.map ~kind:"Request" Fun.id
280
+
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
281
+
~tag_to_string:Fun.id ~tag_compare:String.compare
282
+
|> Jsont.Object.finish
283
+
end
284
+
285
+
module Response = struct
286
+
module Error_code = struct
287
+
type t =
288
+
[ `Parse_error
289
+
| `Invalid_request
290
+
| `Method_not_found
291
+
| `Invalid_params
292
+
| `Internal_error
293
+
| `Custom of int ]
294
+
295
+
let to_int : [< t ] -> int = function
296
+
| `Parse_error -> -32700
297
+
| `Invalid_request -> -32600
298
+
| `Method_not_found -> -32601
299
+
| `Invalid_params -> -32602
300
+
| `Internal_error -> -32603
301
+
| `Custom n -> n
302
+
303
+
let of_int = function
304
+
| -32700 -> `Parse_error
305
+
| -32600 -> `Invalid_request
306
+
| -32601 -> `Method_not_found
307
+
| -32602 -> `Invalid_params
308
+
| -32603 -> `Internal_error
309
+
| n -> `Custom n
310
+
311
+
let jsont : t Jsont.t =
312
+
Jsont.map ~kind:"ErrorCode" ~dec:of_int ~enc:to_int Jsont.int
313
+
end
314
+
315
+
type error_detail = { code : int; message : string; data : Jsont.json option }
316
+
317
+
let error_detail ~code ~message ?data () =
318
+
{ code = Error_code.to_int code; message; data }
319
+
320
+
let error_detail_jsont : error_detail Jsont.t =
321
+
let make code message data = { code; message; data } in
322
+
Jsont.Object.map ~kind:"ErrorDetail" make
323
+
|> Jsont.Object.mem "code" Jsont.int ~enc:(fun e -> e.code)
324
+
|> Jsont.Object.mem "message" Jsont.string ~enc:(fun e -> e.message)
325
+
|> Jsont.Object.opt_mem "data" Jsont.json ~enc:(fun e -> e.data)
326
+
|> Jsont.Object.finish
327
+
328
+
type success = {
329
+
subtype : [ `Success ];
330
+
request_id : string;
331
+
response : Jsont.json option;
332
+
unknown : Unknown.t;
333
+
}
334
+
335
+
type error = {
336
+
subtype : [ `Error ];
337
+
request_id : string;
338
+
error : error_detail;
339
+
unknown : Unknown.t;
340
+
}
341
+
342
+
type t = Success of success | Error of error
343
+
344
+
let success ~request_id ?response ?(unknown = Unknown.empty) () =
345
+
Success { subtype = `Success; request_id; response; unknown }
346
+
347
+
let error ~request_id ~error ?(unknown = Unknown.empty) () =
348
+
Error { subtype = `Error; request_id; error; unknown }
349
+
350
+
(* Individual record codecs *)
351
+
let success_jsont : success Jsont.t =
352
+
let make request_id response (unknown : Unknown.t) : success =
353
+
{ subtype = `Success; request_id; response; unknown }
354
+
in
355
+
Jsont.Object.map ~kind:"Success" make
356
+
|> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun (r : success) ->
357
+
r.request_id)
358
+
|> Jsont.Object.opt_mem "response" Jsont.json ~enc:(fun (r : success) ->
359
+
r.response)
360
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : success) ->
361
+
r.unknown)
362
+
|> Jsont.Object.finish
363
+
364
+
let error_jsont : error Jsont.t =
365
+
let make request_id error (unknown : Unknown.t) : error =
366
+
{ subtype = `Error; request_id; error; unknown }
367
+
in
368
+
Jsont.Object.map ~kind:"Error" make
369
+
|> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun (r : error) ->
370
+
r.request_id)
371
+
|> Jsont.Object.mem "error" error_detail_jsont ~enc:(fun (r : error) ->
372
+
r.error)
373
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : error) ->
374
+
r.unknown)
375
+
|> Jsont.Object.finish
376
+
377
+
(* Main variant codec using subtype discriminator *)
378
+
let jsont : t Jsont.t =
379
+
let case_success =
380
+
Jsont.Object.Case.map "success" success_jsont ~dec:(fun v -> Success v)
381
+
in
382
+
let case_error =
383
+
Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
384
+
in
385
+
386
+
let enc_case = function
387
+
| Success v -> Jsont.Object.Case.value case_success v
388
+
| Error v -> Jsont.Object.Case.value case_error v
389
+
in
390
+
391
+
let cases = Jsont.Object.Case.[ make case_success; make case_error ] in
392
+
393
+
Jsont.Object.map ~kind:"Response" Fun.id
394
+
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
395
+
~tag_to_string:Fun.id ~tag_compare:String.compare
396
+
|> Jsont.Object.finish
397
+
end
398
+
399
+
type control_request = {
400
+
type_ : [ `Control_request ];
401
+
request_id : string;
402
+
request : Request.t;
403
+
unknown : Unknown.t;
404
+
}
405
+
406
+
type control_response = {
407
+
type_ : [ `Control_response ];
408
+
response : Response.t;
409
+
unknown : Unknown.t;
410
+
}
411
+
412
+
type t = Request of control_request | Response of control_response
413
+
414
+
let request ~request_id ~request ?(unknown = Unknown.empty) () =
415
+
Request { type_ = `Control_request; request_id; request; unknown }
416
+
417
+
let response ~response ?(unknown = Unknown.empty) () =
418
+
Response { type_ = `Control_response; response; unknown }
419
+
420
+
(* Individual record codecs *)
421
+
let control_request_jsont : control_request Jsont.t =
422
+
let make request_id request (unknown : Unknown.t) : control_request =
423
+
{ type_ = `Control_request; request_id; request; unknown }
424
+
in
425
+
Jsont.Object.map ~kind:"ControlRequest" make
426
+
|> Jsont.Object.mem "request_id" Jsont.string
427
+
~enc:(fun (r : control_request) -> r.request_id)
428
+
|> Jsont.Object.mem "request" Request.jsont ~enc:(fun (r : control_request) ->
429
+
r.request)
430
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : control_request) ->
431
+
r.unknown)
432
+
|> Jsont.Object.finish
433
+
434
+
let control_response_jsont : control_response Jsont.t =
435
+
let make response (unknown : Unknown.t) : control_response =
436
+
{ type_ = `Control_response; response; unknown }
437
+
in
438
+
Jsont.Object.map ~kind:"ControlResponse" make
439
+
|> Jsont.Object.mem "response" Response.jsont
440
+
~enc:(fun (r : control_response) -> r.response)
441
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : control_response) ->
442
+
r.unknown)
443
+
|> Jsont.Object.finish
444
+
445
+
(* Main variant codec using type discriminator *)
446
+
let jsont : t Jsont.t =
447
+
let case_request =
448
+
Jsont.Object.Case.map "control_request" control_request_jsont ~dec:(fun v ->
449
+
Request v)
450
+
in
451
+
let case_response =
452
+
Jsont.Object.Case.map "control_response" control_response_jsont
453
+
~dec:(fun v -> Response v)
454
+
in
455
+
456
+
let enc_case = function
457
+
| Request v -> Jsont.Object.Case.value case_request v
458
+
| Response v -> Jsont.Object.Case.value case_response v
459
+
in
460
+
461
+
let cases = Jsont.Object.Case.[ make case_request; make case_response ] in
462
+
463
+
Jsont.Object.map ~kind:"Control" Fun.id
464
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
465
+
~tag_to_string:Fun.id ~tag_compare:String.compare
466
+
|> Jsont.Object.finish
467
+
468
+
let pp ppf t = Jsont.pp_value jsont () ppf t
469
+
470
+
let log_request req =
471
+
Log.debug (fun m ->
472
+
m "control request: %a" (Jsont.pp_value Request.jsont ()) req)
473
+
474
+
let log_response resp =
475
+
Log.debug (fun m ->
476
+
m "control response: %a" (Jsont.pp_value Response.jsont ()) resp)
477
+
478
+
(** Server information *)
479
+
module Server_info = struct
480
+
type t = {
481
+
version : string;
482
+
capabilities : string list;
483
+
commands : string list;
484
+
output_styles : string list;
485
+
unknown : Unknown.t;
486
+
}
487
+
488
+
let create ~version ~capabilities ~commands ~output_styles
489
+
?(unknown = Unknown.empty) () =
490
+
{ version; capabilities; commands; output_styles; unknown }
491
+
492
+
let version t = t.version
493
+
let capabilities t = t.capabilities
494
+
let commands t = t.commands
495
+
let output_styles t = t.output_styles
496
+
let unknown t = t.unknown
497
+
498
+
let jsont : t Jsont.t =
499
+
let make version capabilities commands output_styles (unknown : Unknown.t) :
500
+
t =
501
+
{ version; capabilities; commands; output_styles; unknown }
502
+
in
503
+
Jsont.Object.map ~kind:"ServerInfo" make
504
+
|> Jsont.Object.mem "version" Jsont.string ~enc:(fun (r : t) -> r.version)
505
+
|> Jsont.Object.mem "capabilities" (Jsont.list Jsont.string)
506
+
~enc:(fun (r : t) -> r.capabilities)
507
+
~dec_absent:[]
508
+
|> Jsont.Object.mem "commands" (Jsont.list Jsont.string)
509
+
~enc:(fun (r : t) -> r.commands)
510
+
~dec_absent:[]
511
+
|> Jsont.Object.mem "outputStyles" (Jsont.list Jsont.string)
512
+
~enc:(fun (r : t) -> r.output_styles)
513
+
~dec_absent:[]
514
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : t) -> r.unknown)
515
+
|> Jsont.Object.finish
516
+
end
+387
lib/control.mli
+387
lib/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.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 : 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 : 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: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: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 : sig
187
+
type t =
188
+
[ `Parse_error (** -32700: Invalid JSON received *)
189
+
| `Invalid_request (** -32600: The request object is invalid *)
190
+
| `Method_not_found (** -32601: The requested method does not exist *)
191
+
| `Invalid_params (** -32602: Invalid method parameters *)
192
+
| `Internal_error (** -32603: Internal server error *)
193
+
| `Custom of int (** Application-specific error codes *) ]
194
+
195
+
val to_int : [< t ] -> int
196
+
(** [to_int t] converts an error code to its integer representation. *)
197
+
198
+
val of_int : int -> t
199
+
(** [of_int n] converts an integer to a variant. Unknown codes become
200
+
[`Custom n]. *)
201
+
202
+
val jsont : t Jsont.t
203
+
(** [jsont] encodes an error code as a JSON integer. *)
204
+
end
205
+
206
+
type error_detail = {
207
+
code : int; (** Error code for programmatic handling *)
208
+
message : string; (** Human-readable error message *)
209
+
data : Jsont.json option; (** Optional additional error data *)
210
+
}
211
+
(** Structured error detail similar to JSON-RPC.
212
+
213
+
This allows programmatic error handling with numeric error codes and
214
+
optional structured data for additional context. *)
215
+
216
+
val error_detail :
217
+
code:[< Error_code.t ] ->
218
+
message:string ->
219
+
?data:Jsont.json ->
220
+
unit ->
221
+
error_detail
222
+
(** [error_detail ~code ~message ?data ()] creates a structured error detail
223
+
using typed error codes.
224
+
225
+
Example:
226
+
{[
227
+
error_detail ~code:`Method_not_found ~message:"Hook callback not found" ()
228
+
]} *)
229
+
230
+
val error_detail_jsont : error_detail Jsont.t
231
+
(** [error_detail_jsont] is the Jsont codec for error details. *)
232
+
233
+
type success = {
234
+
subtype : [ `Success ];
235
+
request_id : string;
236
+
response : Jsont.json option;
237
+
unknown : Unknown.t;
238
+
}
239
+
(** Successful response. *)
240
+
241
+
type error = {
242
+
subtype : [ `Error ];
243
+
request_id : string;
244
+
error : error_detail;
245
+
unknown : Unknown.t;
246
+
}
247
+
(** Error response with structured error detail. *)
248
+
249
+
type t =
250
+
| Success of success
251
+
| Error of error (** The type of SDK control responses. *)
252
+
253
+
val success :
254
+
request_id:string -> ?response:Jsont.json -> ?unknown:Unknown.t -> unit -> t
255
+
(** [success ~request_id ?response ?unknown ()] creates a success response. *)
256
+
257
+
val error :
258
+
request_id:string -> error:error_detail -> ?unknown:Unknown.t -> unit -> t
259
+
(** [error ~request_id ~error ?unknown] creates an error response with
260
+
structured error detail. *)
261
+
262
+
val jsont : t Jsont.t
263
+
(** [jsont] is the jsont codec for responses. Use [Jsont.pp_value jsont ()]
264
+
for pretty-printing. *)
265
+
end
266
+
267
+
(** {1 Control Messages} *)
268
+
269
+
type control_request = {
270
+
type_ : [ `Control_request ];
271
+
request_id : string;
272
+
request : Request.t;
273
+
unknown : Unknown.t;
274
+
}
275
+
(** Control request message. *)
276
+
277
+
type control_response = {
278
+
type_ : [ `Control_response ];
279
+
response : Response.t;
280
+
unknown : Unknown.t;
281
+
}
282
+
(** Control response message. *)
283
+
284
+
val control_request_jsont : control_request Jsont.t
285
+
(** [control_request_jsont] is the jsont codec for control request messages. *)
286
+
287
+
val control_response_jsont : control_response Jsont.t
288
+
(** [control_response_jsont] is the jsont codec for control response messages.
289
+
*)
290
+
291
+
type t =
292
+
| Request of control_request
293
+
| Response of control_response (** The type of SDK control messages. *)
294
+
295
+
val request :
296
+
request_id:string -> request:Request.t -> ?unknown:Unknown.t -> unit -> t
297
+
(** [request ~request_id ~request ?unknown ()] creates a control request
298
+
message. *)
299
+
300
+
val response : response:Response.t -> ?unknown:Unknown.t -> unit -> t
301
+
(** [response ~response ?unknown ()] creates a control response message. *)
302
+
303
+
val jsont : t Jsont.t
304
+
(** [jsont] is the jsont codec for control messages. Use
305
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
306
+
307
+
val pp : Format.formatter -> t -> unit
308
+
(** [pp ppf t] pretty-prints the SDK control message. *)
309
+
310
+
(** {1 Logging} *)
311
+
312
+
val log_request : Request.t -> unit
313
+
(** [log_request req] logs an SDK control request. *)
314
+
315
+
val log_response : Response.t -> unit
316
+
(** [log_response resp] logs an SDK control response. *)
317
+
318
+
(** {1 Server Information}
319
+
320
+
Server information provides metadata about the Claude CLI server, including
321
+
version, capabilities, available commands, and output styles.
322
+
323
+
{2 Use Cases}
324
+
325
+
- Feature detection: Check if specific capabilities are available
326
+
- Version compatibility: Ensure minimum version requirements
327
+
- Debugging: Log server information for troubleshooting
328
+
- Dynamic adaptation: Adjust SDK behavior based on capabilities
329
+
330
+
{2 Example}
331
+
332
+
{[
333
+
let info = Client.server_info client in
334
+
Printf.printf "Claude CLI version: %s\n" (Server_info.version info);
335
+
336
+
if List.mem "structured-output" (Server_info.capabilities info) then
337
+
Printf.printf "Structured output is supported\n"
338
+
else Printf.printf "Structured output not available\n"
339
+
]} *)
340
+
341
+
module Server_info : sig
342
+
(** Server information and capabilities. *)
343
+
344
+
type t = {
345
+
version : string; (** Server version string (e.g., "2.0.0") *)
346
+
capabilities : string list;
347
+
(** Available server capabilities (e.g., "hooks", "structured-output")
348
+
*)
349
+
commands : string list; (** Available CLI commands *)
350
+
output_styles : string list;
351
+
(** Supported output formats (e.g., "json", "stream-json") *)
352
+
unknown : Unknown.t; (** Unknown fields for forward compatibility *)
353
+
}
354
+
(** Server metadata and capabilities.
355
+
356
+
This information is useful for feature detection and debugging. *)
357
+
358
+
val create :
359
+
version:string ->
360
+
capabilities:string list ->
361
+
commands:string list ->
362
+
output_styles:string list ->
363
+
?unknown:Unknown.t ->
364
+
unit ->
365
+
t
366
+
(** [create ~version ~capabilities ~commands ~output_styles ?unknown ()]
367
+
creates server info. *)
368
+
369
+
val version : t -> string
370
+
(** [version t] returns the server version. *)
371
+
372
+
val capabilities : t -> string list
373
+
(** [capabilities t] returns the server capabilities. *)
374
+
375
+
val commands : t -> string list
376
+
(** [commands t] returns available commands. *)
377
+
378
+
val output_styles : t -> string list
379
+
(** [output_styles t] returns available output styles. *)
380
+
381
+
val unknown : t -> Unknown.t
382
+
(** [unknown t] returns the unknown fields. *)
383
+
384
+
val jsont : t Jsont.t
385
+
(** [jsont] is the jsont codec for server info. Use [Jsont.pp_value jsont ()]
386
+
for pretty-printing. *)
387
+
end
+4
lib/dune
+4
lib/dune
+65
lib/err.ml
+65
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 the claude library. *)
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 ok ~msg = function Ok x -> x | Error e -> raise (Protocol_error (msg ^ e))
62
+
63
+
let ok' ~msg = function
64
+
| Ok x -> x
65
+
| Error e -> raise (Protocol_error (msg ^ e))
+62
lib/err.mli
+62
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 the claude library. *)
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
+
33
+
val process_error : string -> 'a
34
+
(** Raise a process error. *)
35
+
36
+
val connection_error : string -> 'a
37
+
(** Raise a connection error. *)
38
+
39
+
val protocol_error : string -> 'a
40
+
(** Raise a protocol error. *)
41
+
42
+
val timeout : string -> 'a
43
+
(** Raise a timeout error. *)
44
+
45
+
val permission_denied : tool_name:string -> message:string -> 'a
46
+
(** Raise a permission denied error. *)
47
+
48
+
val hook_error : callback_id:string -> message:string -> 'a
49
+
(** Raise a hook error. *)
50
+
51
+
val control_error : request_id:string -> message:string -> 'a
52
+
(** Raise a control error. *)
53
+
54
+
(** {1 Result Helpers} *)
55
+
56
+
val ok : msg:string -> ('a, string) result -> 'a
57
+
(** [ok ~msg result] returns the Ok value or raises Protocol_error with msg
58
+
prefix. *)
59
+
60
+
val ok' : msg:string -> ('a, string) result -> 'a
61
+
(** [ok' ~msg result] returns the Ok value or raises Protocol_error with string
62
+
error. *)
+57
lib/handler.ml
+57
lib/handler.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Object-oriented response handler implementations. *)
7
+
8
+
(** {1 Handler Interface} *)
9
+
10
+
class type handler = object
11
+
method on_text : Response.Text.t -> unit
12
+
method on_tool_use : Response.Tool_use.t -> unit
13
+
method on_tool_result : Content_block.Tool_result.t -> unit
14
+
method on_thinking : Response.Thinking.t -> unit
15
+
method on_init : Response.Init.t -> unit
16
+
method on_error : Response.Error.t -> unit
17
+
method on_complete : Response.Complete.t -> unit
18
+
end
19
+
20
+
(** {1 Concrete Implementations} *)
21
+
22
+
class default : handler =
23
+
object
24
+
method on_text (_ : Response.Text.t) = ()
25
+
method on_tool_use (_ : Response.Tool_use.t) = ()
26
+
method on_tool_result (_ : Content_block.Tool_result.t) = ()
27
+
method on_thinking (_ : Response.Thinking.t) = ()
28
+
method on_init (_ : Response.Init.t) = ()
29
+
method on_error (_ : Response.Error.t) = ()
30
+
method on_complete (_ : Response.Complete.t) = ()
31
+
end
32
+
33
+
class virtual abstract =
34
+
object
35
+
method virtual on_text : Response.Text.t -> unit
36
+
method virtual on_tool_use : Response.Tool_use.t -> unit
37
+
method virtual on_tool_result : Content_block.Tool_result.t -> unit
38
+
method virtual on_thinking : Response.Thinking.t -> unit
39
+
method virtual on_init : Response.Init.t -> unit
40
+
method virtual on_error : Response.Error.t -> unit
41
+
method virtual on_complete : Response.Complete.t -> unit
42
+
end
43
+
44
+
(** {1 Dispatch Functions} *)
45
+
46
+
let dispatch (handler : #handler) (response : Response.t) =
47
+
match response with
48
+
| Response.Text t -> handler#on_text t
49
+
| Response.Tool_use t -> handler#on_tool_use t
50
+
| Response.Tool_result t -> handler#on_tool_result t
51
+
| Response.Thinking t -> handler#on_thinking t
52
+
| Response.Init t -> handler#on_init t
53
+
| Response.Error t -> handler#on_error t
54
+
| Response.Complete t -> handler#on_complete t
55
+
56
+
let dispatch_all (handler : #handler) (responses : Response.t list) =
57
+
List.iter (dispatch handler) responses
+169
lib/handler.mli
+169
lib/handler.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Object-oriented response handler with sensible defaults.
7
+
8
+
This module provides an object-oriented interface for handling response
9
+
events from Claude. It offers both a concrete default implementation (where
10
+
all methods do nothing) and an abstract base class (where all methods must
11
+
be implemented).
12
+
13
+
{1 Usage}
14
+
15
+
The simplest approach is to inherit from {!default} and override only the
16
+
methods you care about:
17
+
18
+
{[
19
+
let my_handler =
20
+
object
21
+
inherit Claude.Handler.default
22
+
method! on_text t = print_endline (Response.Text.content t)
23
+
24
+
method! on_complete c =
25
+
Printf.printf "Done! Cost: $%.4f\n"
26
+
(Option.value ~default:0.0 (Response.Complete.total_cost_usd c))
27
+
end
28
+
]}
29
+
30
+
For compile-time guarantees that all events are handled, inherit from
31
+
{!abstract}:
32
+
33
+
{[
34
+
let complete_handler = object
35
+
inherit Claude.Handler.abstract
36
+
method on_text t = (* must implement *)
37
+
method on_tool_use t = (* must implement *)
38
+
method on_tool_result t = (* must implement *)
39
+
method on_thinking t = (* must implement *)
40
+
method on_init t = (* must implement *)
41
+
method on_error t = (* must implement *)
42
+
method on_complete t = (* must implement *)
43
+
end
44
+
]} *)
45
+
46
+
(** {1 Handler Interface} *)
47
+
48
+
(** The handler interface for processing response events.
49
+
50
+
Each method corresponds to a variant of {!Response.t}. Handlers can be
51
+
passed to {!Client.run} to process responses in an event-driven style. *)
52
+
class type handler = object
53
+
method on_text : Response.Text.t -> unit
54
+
(** [on_text t] is called when text content is received from the assistant. *)
55
+
56
+
method on_tool_use : Response.Tool_use.t -> unit
57
+
(** [on_tool_use t] is called when the assistant requests a tool invocation.
58
+
The caller is responsible for responding with {!Client.respond_to_tool}.
59
+
*)
60
+
61
+
method on_tool_result : Content_block.Tool_result.t -> unit
62
+
(** [on_tool_result t] is called when a tool result is observed in the message
63
+
stream. This is typically an echo of what was sent to Claude. *)
64
+
65
+
method on_thinking : Response.Thinking.t -> unit
66
+
(** [on_thinking t] is called when internal reasoning content is received. *)
67
+
68
+
method on_init : Response.Init.t -> unit
69
+
(** [on_init t] is called when the session is initialized. This provides
70
+
session metadata like session_id and model. *)
71
+
72
+
method on_error : Response.Error.t -> unit
73
+
(** [on_error t] is called when an error occurs. Errors can come from the
74
+
system (e.g., CLI errors) or from the assistant (e.g., rate limits). *)
75
+
76
+
method on_complete : Response.Complete.t -> unit
77
+
(** [on_complete t] is called when the conversation completes. This provides
78
+
final metrics like duration, cost, and token usage. *)
79
+
end
80
+
81
+
(** {1 Concrete Implementations} *)
82
+
83
+
class default : handler
84
+
(** Default handler that does nothing for all events.
85
+
86
+
This is the recommended base class for most use cases. Override only the
87
+
methods you need:
88
+
89
+
{[
90
+
let handler =
91
+
object
92
+
inherit Claude.Handler.default
93
+
method! on_text t = Printf.printf "Text: %s\n" (Response.Text.content t)
94
+
end
95
+
]}
96
+
97
+
Methods you don't override will simply be ignored, making this ideal for
98
+
prototyping and for cases where you only care about specific events. *)
99
+
100
+
(** Abstract handler requiring all methods to be implemented.
101
+
102
+
Use this when you want compile-time guarantees that all events are handled:
103
+
104
+
{[
105
+
let handler = object
106
+
inherit Claude.Handler.abstract
107
+
method on_text t = (* required *)
108
+
method on_tool_use t = (* required *)
109
+
method on_tool_result t = (* required *)
110
+
method on_thinking t = (* required *)
111
+
method on_init t = (* required *)
112
+
method on_error t = (* required *)
113
+
method on_complete t = (* required *)
114
+
end
115
+
]}
116
+
117
+
The compiler will enforce that you implement all methods, ensuring no events
118
+
are silently ignored. *)
119
+
class virtual abstract : object
120
+
method virtual on_text : Response.Text.t -> unit
121
+
(** [on_text t] must be implemented by subclasses. *)
122
+
123
+
method virtual on_tool_use : Response.Tool_use.t -> unit
124
+
(** [on_tool_use t] must be implemented by subclasses. *)
125
+
126
+
method virtual on_tool_result : Content_block.Tool_result.t -> unit
127
+
(** [on_tool_result t] must be implemented by subclasses. *)
128
+
129
+
method virtual on_thinking : Response.Thinking.t -> unit
130
+
(** [on_thinking t] must be implemented by subclasses. *)
131
+
132
+
method virtual on_init : Response.Init.t -> unit
133
+
(** [on_init t] must be implemented by subclasses. *)
134
+
135
+
method virtual on_error : Response.Error.t -> unit
136
+
(** [on_error t] must be implemented by subclasses. *)
137
+
138
+
method virtual on_complete : Response.Complete.t -> unit
139
+
(** [on_complete t] must be implemented by subclasses. *)
140
+
end
141
+
142
+
(** {1 Dispatch Functions} *)
143
+
144
+
val dispatch : #handler -> Response.t -> unit
145
+
(** [dispatch handler response] dispatches a response event to the appropriate
146
+
handler method based on the response type.
147
+
148
+
Example:
149
+
{[
150
+
let handler =
151
+
object
152
+
inherit Claude.Handler.default
153
+
method! on_text t = print_endline (Response.Text.content t)
154
+
end
155
+
in
156
+
dispatch handler (Response.Text text_event)
157
+
]} *)
158
+
159
+
val dispatch_all : #handler -> Response.t list -> unit
160
+
(** [dispatch_all handler responses] dispatches all response events to the
161
+
handler.
162
+
163
+
This is equivalent to calling [List.iter (dispatch handler) responses] but
164
+
may be more convenient:
165
+
166
+
{[
167
+
let responses = Client.receive_all client in
168
+
dispatch_all handler responses
169
+
]} *)
+485
lib/hooks.ml
+485
lib/hooks.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let src = Logs.Src.create "claude.hooks" ~doc:"Claude hooks system"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
(** {1 Hook Events} *)
11
+
12
+
type event =
13
+
| Pre_tool_use
14
+
| Post_tool_use
15
+
| User_prompt_submit
16
+
| Stop
17
+
| Subagent_stop
18
+
| Pre_compact
19
+
20
+
let event_to_string = function
21
+
| Pre_tool_use -> "PreToolUse"
22
+
| Post_tool_use -> "PostToolUse"
23
+
| User_prompt_submit -> "UserPromptSubmit"
24
+
| Stop -> "Stop"
25
+
| Subagent_stop -> "SubagentStop"
26
+
| Pre_compact -> "PreCompact"
27
+
28
+
let event_of_string = function
29
+
| "PreToolUse" -> Pre_tool_use
30
+
| "PostToolUse" -> Post_tool_use
31
+
| "UserPromptSubmit" -> User_prompt_submit
32
+
| "Stop" -> Stop
33
+
| "SubagentStop" -> Subagent_stop
34
+
| "PreCompact" -> Pre_compact
35
+
| s -> raise (Invalid_argument (Fmt.str "Unknown hook event: %s" s))
36
+
37
+
let event_jsont : event Jsont.t =
38
+
Jsont.enum
39
+
[
40
+
("PreToolUse", Pre_tool_use);
41
+
("PostToolUse", Post_tool_use);
42
+
("UserPromptSubmit", User_prompt_submit);
43
+
("Stop", Stop);
44
+
("SubagentStop", Subagent_stop);
45
+
("PreCompact", Pre_compact);
46
+
]
47
+
48
+
(** {1 Decision} *)
49
+
50
+
type decision = Continue | Block
51
+
52
+
let decision_jsont : decision Jsont.t =
53
+
Jsont.enum [ ("continue", Continue); ("block", Block) ]
54
+
55
+
(** {1 Pre_tool_use Hook} *)
56
+
57
+
module Pre_tool_use = struct
58
+
type input = {
59
+
session_id : string;
60
+
transcript_path : string;
61
+
tool_name : string;
62
+
tool_input : Tool_input.t;
63
+
}
64
+
65
+
let input_jsont : input Jsont.t =
66
+
let make session_id transcript_path tool_name tool_input _unknown =
67
+
{
68
+
session_id;
69
+
transcript_path;
70
+
tool_name;
71
+
tool_input = Tool_input.of_json tool_input;
72
+
}
73
+
in
74
+
Jsont.Object.map ~kind:"PreToolUseInput" make
75
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:(fun i -> i.session_id)
76
+
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:(fun i ->
77
+
i.transcript_path)
78
+
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:(fun i -> i.tool_name)
79
+
|> Jsont.Object.mem "tool_input" Jsont.json ~enc:(fun i ->
80
+
Tool_input.to_json i.tool_input)
81
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
82
+
|> Jsont.Object.finish
83
+
84
+
type decision = Allow | Deny | Ask
85
+
86
+
let decision_jsont : decision Jsont.t =
87
+
Jsont.enum [ ("allow", Allow); ("deny", Deny); ("ask", Ask) ]
88
+
89
+
type output = {
90
+
decision : decision option;
91
+
reason : string option;
92
+
updated_input : Tool_input.t option;
93
+
}
94
+
95
+
let allow ?reason ?updated_input () =
96
+
{ decision = Some Allow; reason; updated_input }
97
+
98
+
let deny ?reason () = { decision = Some Deny; reason; updated_input = None }
99
+
let ask ?reason () = { decision = Some Ask; reason; updated_input = None }
100
+
let continue () = { decision = None; reason = None; updated_input = None }
101
+
102
+
let output_jsont : output Jsont.t =
103
+
let make _hook_event_name decision reason updated_input _unknown =
104
+
{
105
+
decision;
106
+
reason;
107
+
updated_input = Option.map Tool_input.of_json updated_input;
108
+
}
109
+
in
110
+
Jsont.Object.map ~kind:"PreToolUseOutput" make
111
+
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ ->
112
+
"PreToolUse")
113
+
|> Jsont.Object.opt_mem "permissionDecision" decision_jsont ~enc:(fun o ->
114
+
o.decision)
115
+
|> Jsont.Object.opt_mem "permissionDecisionReason" Jsont.string
116
+
~enc:(fun o -> o.reason)
117
+
|> Jsont.Object.opt_mem "updatedInput" Jsont.json ~enc:(fun o ->
118
+
Option.map Tool_input.to_json o.updated_input)
119
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
120
+
|> Jsont.Object.finish
121
+
122
+
type callback = input -> output
123
+
end
124
+
125
+
(** {1 Post_tool_use Hook} *)
126
+
127
+
module Post_tool_use = struct
128
+
type input = {
129
+
session_id : string;
130
+
transcript_path : string;
131
+
tool_name : string;
132
+
tool_input : Tool_input.t;
133
+
tool_response : Jsont.json;
134
+
}
135
+
136
+
let input_jsont : input Jsont.t =
137
+
let make session_id transcript_path tool_name tool_input tool_response
138
+
_unknown =
139
+
{
140
+
session_id;
141
+
transcript_path;
142
+
tool_name;
143
+
tool_input = Tool_input.of_json tool_input;
144
+
tool_response;
145
+
}
146
+
in
147
+
Jsont.Object.map ~kind:"PostToolUseInput" make
148
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:(fun i -> i.session_id)
149
+
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:(fun i ->
150
+
i.transcript_path)
151
+
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:(fun i -> i.tool_name)
152
+
|> Jsont.Object.mem "tool_input" Jsont.json ~enc:(fun i ->
153
+
Tool_input.to_json i.tool_input)
154
+
|> Jsont.Object.mem "tool_response" Jsont.json ~enc:(fun i ->
155
+
i.tool_response)
156
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
157
+
|> Jsont.Object.finish
158
+
159
+
type output = {
160
+
block : bool;
161
+
reason : string option;
162
+
additional_context : string option;
163
+
}
164
+
165
+
let continue ?additional_context () =
166
+
{ block = false; reason = None; additional_context }
167
+
168
+
let block ?reason ?additional_context () =
169
+
{ block = true; reason; additional_context }
170
+
171
+
let output_jsont : output Jsont.t =
172
+
let make _hook_event_name decision reason additional_context _unknown =
173
+
{
174
+
block = (match decision with Some Block -> true | _ -> false);
175
+
reason;
176
+
additional_context;
177
+
}
178
+
in
179
+
Jsont.Object.map ~kind:"PostToolUseOutput" make
180
+
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ ->
181
+
"PostToolUse")
182
+
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o ->
183
+
if o.block then Some Block else None)
184
+
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
185
+
|> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o ->
186
+
o.additional_context)
187
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
188
+
|> Jsont.Object.finish
189
+
190
+
type callback = input -> output
191
+
end
192
+
193
+
(** {1 User_prompt_submit Hook} *)
194
+
195
+
module User_prompt_submit = struct
196
+
type input = {
197
+
session_id : string;
198
+
transcript_path : string;
199
+
prompt : string;
200
+
}
201
+
202
+
let input_jsont : input Jsont.t =
203
+
let make session_id transcript_path prompt _unknown =
204
+
{ session_id; transcript_path; prompt }
205
+
in
206
+
Jsont.Object.map ~kind:"UserPromptSubmitInput" make
207
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:(fun i -> i.session_id)
208
+
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:(fun i ->
209
+
i.transcript_path)
210
+
|> Jsont.Object.mem "prompt" Jsont.string ~enc:(fun i -> i.prompt)
211
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
212
+
|> Jsont.Object.finish
213
+
214
+
type output = {
215
+
block : bool;
216
+
reason : string option;
217
+
additional_context : string option;
218
+
}
219
+
220
+
let continue ?additional_context () =
221
+
{ block = false; reason = None; additional_context }
222
+
223
+
let block ?reason () = { block = true; reason; additional_context = None }
224
+
225
+
let output_jsont : output Jsont.t =
226
+
let make _hook_event_name decision reason additional_context _unknown =
227
+
{
228
+
block = (match decision with Some Block -> true | _ -> false);
229
+
reason;
230
+
additional_context;
231
+
}
232
+
in
233
+
Jsont.Object.map ~kind:"UserPromptSubmitOutput" make
234
+
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ ->
235
+
"UserPromptSubmit")
236
+
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o ->
237
+
if o.block then Some Block else None)
238
+
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
239
+
|> Jsont.Object.opt_mem "additionalContext" Jsont.string ~enc:(fun o ->
240
+
o.additional_context)
241
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
242
+
|> Jsont.Object.finish
243
+
244
+
type callback = input -> output
245
+
end
246
+
247
+
(** {1 Stop Hook} *)
248
+
249
+
module Stop = struct
250
+
type input = {
251
+
session_id : string;
252
+
transcript_path : string;
253
+
stop_hook_active : bool;
254
+
}
255
+
256
+
let input_jsont : input Jsont.t =
257
+
let make session_id transcript_path stop_hook_active _unknown =
258
+
{ session_id; transcript_path; stop_hook_active }
259
+
in
260
+
Jsont.Object.map ~kind:"StopInput" make
261
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:(fun i -> i.session_id)
262
+
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:(fun i ->
263
+
i.transcript_path)
264
+
|> Jsont.Object.mem "stop_hook_active" Jsont.bool ~enc:(fun i ->
265
+
i.stop_hook_active)
266
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
267
+
|> Jsont.Object.finish
268
+
269
+
type output = { block : bool; reason : string option }
270
+
271
+
let continue () = { block = false; reason = None }
272
+
let block ?reason () = { block = true; reason }
273
+
274
+
let output_jsont_with_event_name event_name : output Jsont.t =
275
+
let make _hook_event_name decision reason _unknown =
276
+
{
277
+
block = (match decision with Some Block -> true | _ -> false);
278
+
reason;
279
+
}
280
+
in
281
+
Jsont.Object.map ~kind:(event_name ^ "Output") make
282
+
|> Jsont.Object.mem "hookEventName" Jsont.string ~enc:(fun _ -> event_name)
283
+
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun o ->
284
+
if o.block then Some Block else None)
285
+
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun o -> o.reason)
286
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
287
+
|> Jsont.Object.finish
288
+
289
+
let output_jsont = output_jsont_with_event_name "Stop"
290
+
291
+
type callback = input -> output
292
+
end
293
+
294
+
(** {1 Subagent_stop Hook} *)
295
+
296
+
module Subagent_stop = struct
297
+
type input = Stop.input
298
+
type output = Stop.output
299
+
300
+
let continue = Stop.continue
301
+
let block = Stop.block
302
+
let input_jsont = Stop.input_jsont
303
+
let output_jsont = Stop.output_jsont_with_event_name "SubagentStop"
304
+
305
+
type callback = input -> output
306
+
end
307
+
308
+
(** {1 Pre_compact Hook} *)
309
+
310
+
module Pre_compact = struct
311
+
type input = { session_id : string; transcript_path : string }
312
+
313
+
let input_jsont : input Jsont.t =
314
+
let make session_id transcript_path _unknown =
315
+
{ session_id; transcript_path }
316
+
in
317
+
Jsont.Object.map ~kind:"PreCompactInput" make
318
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:(fun i -> i.session_id)
319
+
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:(fun i ->
320
+
i.transcript_path)
321
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
322
+
|> Jsont.Object.finish
323
+
324
+
type callback = input -> unit
325
+
end
326
+
327
+
(** {1 Generic Hook Result} *)
328
+
329
+
type result = {
330
+
decision : decision option;
331
+
system_message : string option;
332
+
hook_specific_output : Jsont.json option;
333
+
}
334
+
335
+
let result_jsont : result Jsont.t =
336
+
let make decision system_message hook_specific_output _unknown =
337
+
{ decision; system_message; hook_specific_output }
338
+
in
339
+
Jsont.Object.map ~kind:"Result" make
340
+
|> Jsont.Object.opt_mem "decision" decision_jsont ~enc:(fun r -> r.decision)
341
+
|> Jsont.Object.opt_mem "systemMessage" Jsont.string ~enc:(fun r ->
342
+
r.system_message)
343
+
|> Jsont.Object.opt_mem "hookSpecificOutput" Jsont.json ~enc:(fun r ->
344
+
r.hook_specific_output)
345
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
346
+
|> Jsont.Object.finish
347
+
348
+
let continue_result ?system_message ?hook_specific_output () =
349
+
{ decision = None; system_message; hook_specific_output }
350
+
351
+
let block_result ?system_message ?hook_specific_output () =
352
+
{ decision = Some Block; system_message; hook_specific_output }
353
+
354
+
(** {1 Hook Configuration} *)
355
+
356
+
type hook_entry =
357
+
| Pre_tool_use_hook of (string option * Pre_tool_use.callback)
358
+
| Post_tool_use_hook of (string option * Post_tool_use.callback)
359
+
| User_prompt_submit_hook of User_prompt_submit.callback
360
+
| Stop_hook of Stop.callback
361
+
| Subagent_stop_hook of Subagent_stop.callback
362
+
| Pre_compact_hook of Pre_compact.callback
363
+
364
+
type t = hook_entry list
365
+
366
+
let pp ppf t = Fmt.pf ppf "<hooks:%d>" (List.length t)
367
+
let empty = []
368
+
369
+
let on_pre_tool_use ?pattern callback config =
370
+
Pre_tool_use_hook (pattern, callback) :: config
371
+
372
+
let on_post_tool_use ?pattern callback config =
373
+
Post_tool_use_hook (pattern, callback) :: config
374
+
375
+
let on_user_prompt_submit callback config =
376
+
User_prompt_submit_hook callback :: config
377
+
378
+
let on_stop callback config = Stop_hook callback :: config
379
+
let on_subagent_stop callback config = Subagent_stop_hook callback :: config
380
+
let on_pre_compact callback config = Pre_compact_hook callback :: config
381
+
382
+
(** {1 Internal - Conversion to Wire Format} *)
383
+
384
+
let decode_input name jsont json =
385
+
match Jsont.Json.decode jsont json with
386
+
| Ok input -> input
387
+
| Error msg ->
388
+
Log.err (fun m -> m "%s: failed to decode input: %s" name msg);
389
+
raise (Invalid_argument (name ^ " input: " ^ msg))
390
+
391
+
let encode_output name jsont output =
392
+
match Jsont.Json.encode jsont output with
393
+
| Ok json -> json
394
+
| Error msg -> failwith (name ^ " output encoding: " ^ msg)
395
+
396
+
let wire_callback ~name ~input_jsont ~output_jsont ~should_block callback json =
397
+
let typed_input = decode_input name input_jsont json in
398
+
let typed_output = callback typed_input in
399
+
let hook_specific_output = encode_output name output_jsont typed_output in
400
+
if should_block typed_output then block_result ~hook_specific_output ()
401
+
else continue_result ~hook_specific_output ()
402
+
403
+
let group_hooks config =
404
+
let pre_tool_use = ref [] in
405
+
let post_tool_use = ref [] in
406
+
let user_prompt_submit = ref [] in
407
+
let stop = ref [] in
408
+
let subagent_stop = ref [] in
409
+
let pre_compact = ref [] in
410
+
List.iter
411
+
(function
412
+
| Pre_tool_use_hook (pattern, callback) ->
413
+
pre_tool_use := (pattern, callback) :: !pre_tool_use
414
+
| Post_tool_use_hook (pattern, callback) ->
415
+
post_tool_use := (pattern, callback) :: !post_tool_use
416
+
| User_prompt_submit_hook callback ->
417
+
user_prompt_submit := (None, callback) :: !user_prompt_submit
418
+
| Stop_hook callback -> stop := (None, callback) :: !stop
419
+
| Subagent_stop_hook callback ->
420
+
subagent_stop := (None, callback) :: !subagent_stop
421
+
| Pre_compact_hook callback ->
422
+
pre_compact := (None, callback) :: !pre_compact)
423
+
config;
424
+
( !pre_tool_use,
425
+
!post_tool_use,
426
+
!user_prompt_submit,
427
+
!stop,
428
+
!subagent_stop,
429
+
!pre_compact )
430
+
431
+
let add_standard_event event hooks ~name ~input_jsont ~output_jsont
432
+
~should_block result =
433
+
match hooks with
434
+
| [] -> result
435
+
| _ ->
436
+
let wire_callbacks =
437
+
List.map
438
+
(fun (pattern, callback) ->
439
+
( pattern,
440
+
wire_callback ~name ~input_jsont ~output_jsont ~should_block
441
+
callback ))
442
+
hooks
443
+
in
444
+
(event, wire_callbacks) :: result
445
+
446
+
let add_pre_compact_event hooks result =
447
+
match hooks with
448
+
| [] -> result
449
+
| _ ->
450
+
let wire_callbacks =
451
+
List.map
452
+
(fun (pattern, callback) ->
453
+
let wire_callback json =
454
+
let typed_input =
455
+
decode_input "PreCompact" Pre_compact.input_jsont json
456
+
in
457
+
callback typed_input;
458
+
continue_result ()
459
+
in
460
+
(pattern, wire_callback))
461
+
hooks
462
+
in
463
+
(Pre_compact, wire_callbacks) :: result
464
+
465
+
let callbacks config =
466
+
let ptu, potu, ups, st, sas, pc = group_hooks config in
467
+
[]
468
+
|> add_standard_event Pre_tool_use ptu ~name:"PreToolUse"
469
+
~input_jsont:Pre_tool_use.input_jsont
470
+
~output_jsont:Pre_tool_use.output_jsont ~should_block:(fun _ -> false)
471
+
|> add_standard_event Post_tool_use potu ~name:"PostToolUse"
472
+
~input_jsont:Post_tool_use.input_jsont
473
+
~output_jsont:Post_tool_use.output_jsont ~should_block:(fun o ->
474
+
o.Post_tool_use.block)
475
+
|> add_standard_event User_prompt_submit ups ~name:"UserPromptSubmit"
476
+
~input_jsont:User_prompt_submit.input_jsont
477
+
~output_jsont:User_prompt_submit.output_jsont ~should_block:(fun o ->
478
+
o.User_prompt_submit.block)
479
+
|> add_standard_event Stop st ~name:"Stop" ~input_jsont:Stop.input_jsont
480
+
~output_jsont:Stop.output_jsont ~should_block:(fun o -> o.Stop.block)
481
+
|> add_standard_event Subagent_stop sas ~name:"SubagentStop"
482
+
~input_jsont:Subagent_stop.input_jsont
483
+
~output_jsont:Subagent_stop.output_jsont ~should_block:(fun o ->
484
+
o.Stop.block)
485
+
|> add_pre_compact_event pc |> List.rev
+228
lib/hooks.mli
+228
lib/hooks.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Fully typed hook callbacks.
7
+
8
+
Hooks allow you to intercept and control events in Claude Code sessions,
9
+
using fully typed OCaml values instead of raw JSON.
10
+
11
+
{1 Example Usage}
12
+
13
+
{[
14
+
open Eio.Std
15
+
16
+
(* Block dangerous bash commands *)
17
+
let block_rm_rf input =
18
+
if input.Hooks.Pre_tool_use.tool_name = "Bash" then
19
+
match Tool_input.string input.tool_input "command" with
20
+
| Some cmd when String.contains cmd "rm -rf" ->
21
+
Hooks.Pre_tool_use.deny ~reason:"Dangerous command" ()
22
+
| _ -> Hooks.Pre_tool_use.continue ()
23
+
else Hooks.Pre_tool_use.continue ()
24
+
25
+
let hooks =
26
+
Hooks.empty
27
+
|> Hooks.on_pre_tool_use ~pattern:"Bash" block_rm_rf
28
+
29
+
let options = Claude.Options.create ~hooks () in
30
+
let client = Claude.Client.v ~options ~sw ~process_mgr () in
31
+
]} *)
32
+
33
+
val src : Logs.Src.t
34
+
(** The log source for hooks. *)
35
+
36
+
(** {1 Hook Events} *)
37
+
38
+
type event =
39
+
| Pre_tool_use
40
+
| Post_tool_use
41
+
| User_prompt_submit
42
+
| Stop
43
+
| Subagent_stop
44
+
| Pre_compact
45
+
46
+
val event_to_string : event -> string
47
+
(** Wire format strings: "PreToolUse", "PostToolUse", "UserPromptSubmit",
48
+
"Stop", "SubagentStop", "PreCompact". *)
49
+
50
+
val event_of_string : string -> event
51
+
(** @raise Invalid_argument if the string is not a known event. *)
52
+
53
+
val event_jsont : event Jsont.t
54
+
55
+
(** {1 Decision} *)
56
+
57
+
type decision = Continue | Block
58
+
59
+
val decision_jsont : decision Jsont.t
60
+
61
+
(** {1 Hook Types} *)
62
+
63
+
(** Pre_tool_use hook - fires before tool execution. *)
64
+
module Pre_tool_use : sig
65
+
type input = {
66
+
session_id : string;
67
+
transcript_path : string;
68
+
tool_name : string;
69
+
tool_input : Tool_input.t;
70
+
}
71
+
72
+
val input_jsont : input Jsont.t
73
+
74
+
type decision = Allow | Deny | Ask
75
+
76
+
val decision_jsont : decision Jsont.t
77
+
78
+
type output = {
79
+
decision : decision option;
80
+
reason : string option;
81
+
updated_input : Tool_input.t option;
82
+
}
83
+
84
+
val output_jsont : output Jsont.t
85
+
val allow : ?reason:string -> ?updated_input:Tool_input.t -> unit -> output
86
+
val deny : ?reason:string -> unit -> output
87
+
val ask : ?reason:string -> unit -> output
88
+
val continue : unit -> output
89
+
90
+
type callback = input -> output
91
+
end
92
+
93
+
(** Post_tool_use hook - fires after tool execution. *)
94
+
module Post_tool_use : sig
95
+
type input = {
96
+
session_id : string;
97
+
transcript_path : string;
98
+
tool_name : string;
99
+
tool_input : Tool_input.t;
100
+
tool_response : Jsont.json;
101
+
}
102
+
103
+
val input_jsont : input Jsont.t
104
+
105
+
type output = {
106
+
block : bool;
107
+
reason : string option;
108
+
additional_context : string option;
109
+
}
110
+
111
+
val output_jsont : output Jsont.t
112
+
val continue : ?additional_context:string -> unit -> output
113
+
val block : ?reason:string -> ?additional_context:string -> unit -> output
114
+
115
+
type callback = input -> output
116
+
end
117
+
118
+
(** User_prompt_submit hook - fires when user submits a prompt. *)
119
+
module User_prompt_submit : sig
120
+
type input = {
121
+
session_id : string;
122
+
transcript_path : string;
123
+
prompt : string;
124
+
}
125
+
126
+
val input_jsont : input Jsont.t
127
+
128
+
type output = {
129
+
block : bool;
130
+
reason : string option;
131
+
additional_context : string option;
132
+
}
133
+
134
+
val output_jsont : output Jsont.t
135
+
val continue : ?additional_context:string -> unit -> output
136
+
val block : ?reason:string -> unit -> output
137
+
138
+
type callback = input -> output
139
+
end
140
+
141
+
(** Stop hook - fires when conversation stops. *)
142
+
module Stop : sig
143
+
type input = {
144
+
session_id : string;
145
+
transcript_path : string;
146
+
stop_hook_active : bool;
147
+
}
148
+
149
+
val input_jsont : input Jsont.t
150
+
151
+
type output = { block : bool; reason : string option }
152
+
153
+
val output_jsont : output Jsont.t
154
+
val continue : unit -> output
155
+
val block : ?reason:string -> unit -> output
156
+
157
+
type callback = input -> output
158
+
end
159
+
160
+
(** Subagent_stop hook - fires when a subagent stops. *)
161
+
module Subagent_stop : sig
162
+
type input = Stop.input
163
+
type output = Stop.output
164
+
165
+
val input_jsont : input Jsont.t
166
+
val output_jsont : output Jsont.t
167
+
val continue : unit -> output
168
+
val block : ?reason:string -> unit -> output
169
+
170
+
type callback = input -> output
171
+
end
172
+
173
+
(** Pre_compact hook - fires before message compaction. *)
174
+
module Pre_compact : sig
175
+
type input = { session_id : string; transcript_path : string }
176
+
177
+
val input_jsont : input Jsont.t
178
+
179
+
type callback = input -> unit
180
+
(** Pre_compact hooks have no output - they are notification-only. *)
181
+
end
182
+
183
+
(** {1 Generic Hook Result} *)
184
+
185
+
type result = {
186
+
decision : decision option;
187
+
system_message : string option;
188
+
hook_specific_output : Jsont.json option;
189
+
}
190
+
191
+
val result_jsont : result Jsont.t
192
+
193
+
val continue_result :
194
+
?system_message:string -> ?hook_specific_output:Jsont.json -> unit -> result
195
+
196
+
val block_result :
197
+
?system_message:string -> ?hook_specific_output:Jsont.json -> unit -> result
198
+
199
+
(** {1 Hook Configuration} *)
200
+
201
+
type t
202
+
(** Hook configuration.
203
+
204
+
Hooks are configured using a builder pattern:
205
+
{[
206
+
Hooks.empty
207
+
|> Hooks.on_pre_tool_use ~pattern:"Bash" bash_handler
208
+
|> Hooks.on_post_tool_use post_handler
209
+
]} *)
210
+
211
+
val pp : Format.formatter -> t -> unit
212
+
val empty : t
213
+
val on_pre_tool_use : ?pattern:string -> Pre_tool_use.callback -> t -> t
214
+
val on_post_tool_use : ?pattern:string -> Post_tool_use.callback -> t -> t
215
+
val on_user_prompt_submit : User_prompt_submit.callback -> t -> t
216
+
val on_stop : Stop.callback -> t -> t
217
+
val on_subagent_stop : Subagent_stop.callback -> t -> t
218
+
val on_pre_compact : Pre_compact.callback -> t -> t
219
+
220
+
(** {1 Internal - for client use} *)
221
+
222
+
val callbacks :
223
+
t -> (event * (string option * (Jsont.json -> result)) list) list
224
+
(** [callbacks config] returns hook configuration in format suitable for
225
+
registration with the CLI.
226
+
227
+
Internal function used by {!Client}; you should not need to call it
228
+
directly. *)
+90
lib/incoming.ml
+90
lib/incoming.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.incoming" ~doc:"Incoming messages from Claude CLI"
8
+
9
+
module Log = (val Logs.src_log src : Logs.LOG)
10
+
11
+
(** Incoming messages from Claude CLI.
12
+
13
+
The top-level discriminator is the "type" field. *)
14
+
15
+
type t =
16
+
| Message of Message.t
17
+
| Control_response of Control.control_response
18
+
| Control_request of Control.control_request
19
+
| Rate_limit_event
20
+
21
+
let jsont : t Jsont.t =
22
+
(* Message types use "user", "assistant", "system", "result" as type values.
23
+
Control uses "control_request" and "control_response".
24
+
25
+
We use case_mem for all types. Note: we use the inner message codecs
26
+
(User.incoming_jsont, etc.) rather than Message.jsont to avoid nesting
27
+
case_mem on the same "type" field. *)
28
+
let case_control_request =
29
+
Jsont.Object.Case.map "control_request" Control.control_request_jsont
30
+
~dec:(fun v -> Control_request v)
31
+
in
32
+
let case_control_response =
33
+
Jsont.Object.Case.map "control_response" Control.control_response_jsont
34
+
~dec:(fun v -> Control_response v)
35
+
in
36
+
let case_user =
37
+
Jsont.Object.Case.map "user" Message.User.incoming_jsont ~dec:(fun v ->
38
+
Message (Message.User v))
39
+
in
40
+
let case_assistant =
41
+
Jsont.Object.Case.map "assistant" Message.Assistant.incoming_jsont
42
+
~dec:(fun v -> Message (Message.Assistant v))
43
+
in
44
+
let case_system =
45
+
Jsont.Object.Case.map "system" Message.System.jsont ~dec:(fun v ->
46
+
Message (Message.System v))
47
+
in
48
+
let case_result =
49
+
Jsont.Object.Case.map "result" Message.Result.jsont ~dec:(fun v ->
50
+
Message (Message.Result v))
51
+
in
52
+
(* rate_limit_event: CLI sends these periodically with usage info.
53
+
We decode the type field and discard the rest. *)
54
+
let rate_limit_jsont =
55
+
Jsont.Object.map ~kind:"RateLimit" ()
56
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
57
+
in
58
+
let case_rate_limit =
59
+
Jsont.Object.Case.map "rate_limit_event" rate_limit_jsont ~dec:(fun () ->
60
+
Rate_limit_event)
61
+
in
62
+
let enc_case = function
63
+
| Control_request v -> Jsont.Object.Case.value case_control_request v
64
+
| Control_response v -> Jsont.Object.Case.value case_control_response v
65
+
| Rate_limit_event -> Jsont.Object.Case.value case_rate_limit ()
66
+
| Message msg -> (
67
+
match msg with
68
+
| Message.User u -> Jsont.Object.Case.value case_user u
69
+
| Message.Assistant a -> Jsont.Object.Case.value case_assistant a
70
+
| Message.System s -> Jsont.Object.Case.value case_system s
71
+
| Message.Result r -> Jsont.Object.Case.value case_result r)
72
+
in
73
+
let cases =
74
+
Jsont.Object.Case.
75
+
[
76
+
make case_control_request;
77
+
make case_control_response;
78
+
make case_user;
79
+
make case_assistant;
80
+
make case_system;
81
+
make case_result;
82
+
make case_rate_limit;
83
+
]
84
+
in
85
+
Jsont.Object.map ~kind:"Incoming" Fun.id
86
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
87
+
~tag_to_string:Fun.id ~tag_compare:String.compare
88
+
|> Jsont.Object.finish
89
+
90
+
let pp ppf t = Jsont.pp_value jsont () ppf t
+30
lib/incoming.mli
+30
lib/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.control_response
22
+
| Control_request of Control.control_request
23
+
| Rate_limit_event (** Rate limit usage info from the CLI. *)
24
+
25
+
val jsont : t Jsont.t
26
+
(** Codec for incoming messages. Uses the "type" field to discriminate. Use
27
+
[Jsont.pp_value jsont ()] for pretty-printing. *)
28
+
29
+
val pp : Format.formatter -> t -> unit
30
+
(** [pp ppf t] pretty-prints the incoming message. *)
+155
lib/mcp_server.ml
+155
lib/mcp_server.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module J = Jsont.Json
7
+
8
+
type t = {
9
+
name : string;
10
+
version : string;
11
+
tools : Tool.t list;
12
+
tool_map : (string, Tool.t) Hashtbl.t;
13
+
}
14
+
15
+
let v ~name ?(version = "1.0.0") ~tools () =
16
+
let tool_map = Hashtbl.create (List.length tools) in
17
+
List.iter (fun tool -> Hashtbl.add tool_map (Tool.name tool) tool) tools;
18
+
{ name; version; tools; tool_map }
19
+
20
+
let name t = t.name
21
+
let version t = t.version
22
+
let tools t = t.tools
23
+
24
+
(* JSONRPC helpers using Jsont.Json builders *)
25
+
26
+
let jsonrpc_success ~id result =
27
+
J.object'
28
+
[
29
+
J.mem (J.name "jsonrpc") (J.string "2.0");
30
+
J.mem (J.name "id") id;
31
+
J.mem (J.name "result") result;
32
+
]
33
+
34
+
let jsonrpc_error ~id ~code ~message =
35
+
J.object'
36
+
[
37
+
J.mem (J.name "jsonrpc") (J.string "2.0");
38
+
J.mem (J.name "id") id;
39
+
J.mem (J.name "error")
40
+
(J.object'
41
+
[
42
+
J.mem (J.name "code") (J.number (Float.of_int code));
43
+
J.mem (J.name "message") (J.string message);
44
+
]);
45
+
]
46
+
47
+
(* Extract string from JSON *)
48
+
let string_of key (obj : Jsont.json) =
49
+
match obj with
50
+
| Jsont.Object (mems, _) -> (
51
+
match J.find_mem key mems with
52
+
| Some (_, Jsont.String (s, _)) -> Some s
53
+
| _ -> None)
54
+
| _ -> None
55
+
56
+
(* Extract object from JSON *)
57
+
let object_of key (obj : Jsont.json) : Jsont.json option =
58
+
match obj with
59
+
| Jsont.Object (mems, _) -> (
60
+
match J.find_mem key mems with
61
+
| Some (_, (Jsont.Object _ as o)) -> Some o
62
+
| _ -> None)
63
+
| _ -> None
64
+
65
+
(* Get ID from JSON message *)
66
+
let msg_id (msg : Jsont.json) : Jsont.json =
67
+
match msg with
68
+
| Jsont.Object (mems, _) -> (
69
+
match J.find_mem "id" mems with Some (_, id) -> id | None -> J.null ())
70
+
| _ -> J.null ()
71
+
72
+
(* Handle initialize request *)
73
+
let handle_initialize t ~id =
74
+
jsonrpc_success ~id
75
+
(J.object'
76
+
[
77
+
J.mem (J.name "protocolVersion") (J.string "2024-11-05");
78
+
J.mem (J.name "capabilities")
79
+
(J.object' [ J.mem (J.name "tools") (J.object' []) ]);
80
+
J.mem (J.name "serverInfo")
81
+
(J.object'
82
+
[
83
+
J.mem (J.name "name") (J.string t.name);
84
+
J.mem (J.name "version") (J.string t.version);
85
+
]);
86
+
])
87
+
88
+
(* Handle tools/list request *)
89
+
let handle_tools_list t ~id =
90
+
let tools_json =
91
+
List.map
92
+
(fun tool ->
93
+
J.object'
94
+
[
95
+
J.mem (J.name "name") (J.string (Tool.name tool));
96
+
J.mem (J.name "description") (J.string (Tool.description tool));
97
+
J.mem (J.name "inputSchema") (Tool.input_schema tool);
98
+
])
99
+
t.tools
100
+
in
101
+
jsonrpc_success ~id (J.object' [ J.mem (J.name "tools") (J.list tools_json) ])
102
+
103
+
(* Handle tools/call request *)
104
+
let handle_tools_call t ~id ~params =
105
+
match string_of "name" params with
106
+
| None -> jsonrpc_error ~id ~code:(-32602) ~message:"Missing 'name' parameter"
107
+
| Some tool_name -> (
108
+
match Hashtbl.find_opt t.tool_map tool_name with
109
+
| None ->
110
+
jsonrpc_error ~id ~code:(-32601)
111
+
~message:(Fmt.str "Tool '%s' not found" tool_name)
112
+
| Some tool -> (
113
+
let arguments =
114
+
match object_of "arguments" params with
115
+
| Some args -> args
116
+
| None -> J.object' []
117
+
in
118
+
let input = Tool_input.of_json arguments in
119
+
match Tool.call tool input with
120
+
| Ok content ->
121
+
jsonrpc_success ~id
122
+
(J.object' [ J.mem (J.name "content") content ])
123
+
| Error msg ->
124
+
(* Return error as content with is_error flag *)
125
+
jsonrpc_success ~id
126
+
(J.object'
127
+
[
128
+
J.mem (J.name "content")
129
+
(J.list
130
+
[
131
+
J.object'
132
+
[
133
+
J.mem (J.name "type") (J.string "text");
134
+
J.mem (J.name "text") (J.string msg);
135
+
];
136
+
]);
137
+
J.mem (J.name "isError") (J.bool true);
138
+
])))
139
+
140
+
let handle_request t ~method_ ~params ~id =
141
+
match method_ with
142
+
| "initialize" -> handle_initialize t ~id
143
+
| "tools/list" -> handle_tools_list t ~id
144
+
| "tools/call" -> handle_tools_call t ~id ~params
145
+
| _ ->
146
+
jsonrpc_error ~id ~code:(-32601)
147
+
~message:(Fmt.str "Method '%s' not found" method_)
148
+
149
+
let handle_json_message t (msg : Jsont.json) =
150
+
let method_ = match string_of "method" msg with Some m -> m | None -> "" in
151
+
let params =
152
+
match object_of "params" msg with Some p -> p | None -> J.object' []
153
+
in
154
+
let id = msg_id msg in
155
+
handle_request t ~method_ ~params ~id
+86
lib/mcp_server.mli
+86
lib/mcp_server.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** In-process MCP server for custom tools.
7
+
8
+
SDK MCP servers run directly in your OCaml application, eliminating
9
+
subprocess overhead. They handle MCP protocol requests (tools/list,
10
+
tools/call) and route them to your tool handlers.
11
+
12
+
{2 Basic Usage}
13
+
14
+
{[
15
+
let greet =
16
+
Tool.v ~name:"greet" ~description:"Greet a user"
17
+
~input_schema:
18
+
(Tool.schema_object
19
+
[ ("name", Tool.schema_string) ]
20
+
~required:[ "name" ])
21
+
~handler:(fun args ->
22
+
match Tool_input.string args "name" with
23
+
| Some name ->
24
+
Ok (Tool.text_result (Printf.sprintf "Hello, %s!" name))
25
+
| None -> Error "Missing name")
26
+
27
+
let server = Mcp_server.v ~name:"my-tools" ~tools:[ greet ] ()
28
+
29
+
let options =
30
+
Options.default
31
+
|> Options.with_mcp_server ~name:"tools" server
32
+
|> Options.with_allowed_tools [ "mcp__tools__greet" ]
33
+
]}
34
+
35
+
{2 Tool Naming}
36
+
37
+
When you register an MCP server with name "foo" containing a tool "bar", the
38
+
full tool name becomes [mcp__foo__bar]. This is how Claude CLI routes MCP
39
+
tool calls.
40
+
41
+
{2 Protocol}
42
+
43
+
The server handles these MCP JSONRPC methods:
44
+
- [initialize]: Returns server capabilities
45
+
- [tools/list]: Returns available tools with schemas
46
+
- [tools/call]: Executes a tool and returns result *)
47
+
48
+
type t
49
+
(** Abstract type for MCP servers. *)
50
+
51
+
val v : name:string -> ?version:string -> tools:Tool.t list -> unit -> t
52
+
(** [v ~name ?version ~tools ()] creates an in-process MCP server.
53
+
54
+
@param name Server identifier. Used in tool naming: [mcp__<name>__<tool>].
55
+
@param version Server version string (default "1.0.0").
56
+
@param tools List of tools this server provides. *)
57
+
58
+
val name : t -> string
59
+
(** [name t] returns the server name. *)
60
+
61
+
val version : t -> string
62
+
(** [version t] returns the server version. *)
63
+
64
+
val tools : t -> Tool.t list
65
+
(** [tools t] returns the list of registered tools. *)
66
+
67
+
(** {1 MCP Protocol Handling} *)
68
+
69
+
val handle_request :
70
+
t -> method_:string -> params:Jsont.json -> id:Jsont.json -> Jsont.json
71
+
(** [handle_request t ~method_ ~params ~id] handles an MCP JSONRPC request.
72
+
73
+
Returns a JSONRPC response object with the given [id].
74
+
75
+
Supported methods:
76
+
- ["initialize"]: Returns server capabilities (tools only)
77
+
- ["tools/list"]: Returns list of available tools
78
+
- ["tools/call"]: Executes tool, params must have "name" and "arguments"
79
+
80
+
Unknown methods return a JSONRPC error response. *)
81
+
82
+
val handle_json_message : t -> Jsont.json -> Jsont.json
83
+
(** [handle_json_message t msg] handles a complete JSONRPC message.
84
+
85
+
Extracts method, params, and id from the message and delegates to
86
+
{!handle_request}. *)
+452
lib/message.ml
+452
lib/message.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let src = Logs.Src.create "claude.message" ~doc:"Claude messages"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
module User = struct
11
+
type content = String of string | Blocks of Content_block.t list
12
+
type t = { content : content; unknown : Unknown.t }
13
+
14
+
let of_string s = { content = String s; unknown = Unknown.empty }
15
+
let of_blocks blocks = { content = Blocks blocks; unknown = Unknown.empty }
16
+
17
+
let with_tool_result ~tool_use_id ~content ?is_error () =
18
+
let tool_result =
19
+
Content_block.tool_result ~tool_use_id ~content ?is_error ()
20
+
in
21
+
{ content = Blocks [ tool_result ]; unknown = Unknown.empty }
22
+
23
+
let make content unknown = { content; unknown }
24
+
let content t = t.content
25
+
let unknown t = t.unknown
26
+
let as_text t = match t.content with String s -> Some s | Blocks _ -> None
27
+
28
+
let blocks t =
29
+
match t.content with
30
+
| String s -> [ Content_block.text s ]
31
+
| Blocks bs -> bs
32
+
33
+
let decode_content json =
34
+
match json with
35
+
| Jsont.String (s, _) -> String s
36
+
| Jsont.Array (items, _) ->
37
+
let blocks =
38
+
List.map
39
+
(fun j ->
40
+
match Jsont.Json.decode Content_block.jsont j with
41
+
| Ok v -> v
42
+
| Error e -> invalid_arg ("Invalid content block: " ^ e))
43
+
items
44
+
in
45
+
Blocks blocks
46
+
| _ -> failwith "Content must be string or array"
47
+
48
+
let encode_content = function
49
+
| String s -> Jsont.String (s, Jsont.Meta.none)
50
+
| Blocks blocks ->
51
+
let jsons =
52
+
List.map
53
+
(fun b ->
54
+
match Jsont.Json.encode Content_block.jsont b with
55
+
| Ok json -> json
56
+
| Error e -> invalid_arg ("encode_content: " ^ e))
57
+
blocks
58
+
in
59
+
Jsont.Array (jsons, Jsont.Meta.none)
60
+
61
+
let jsont : t Jsont.t =
62
+
Jsont.Object.map ~kind:"User" (fun json_content unknown ->
63
+
let content = decode_content json_content in
64
+
make content unknown)
65
+
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t ->
66
+
encode_content (content t))
67
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
68
+
|> Jsont.Object.finish
69
+
70
+
let incoming_jsont : t Jsont.t =
71
+
let message_jsont =
72
+
Jsont.Object.map ~kind:"UserMessage" (fun json_content ->
73
+
let content = decode_content json_content in
74
+
{ content; unknown = Unknown.empty })
75
+
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t ->
76
+
encode_content (content t))
77
+
|> Jsont.Object.finish
78
+
in
79
+
Jsont.Object.map ~kind:"UserEnvelope" Fun.id
80
+
|> Jsont.Object.mem "message" message_jsont ~enc:Fun.id
81
+
|> Jsont.Object.finish
82
+
83
+
let outgoing_jsont : t Jsont.t =
84
+
let message_jsont =
85
+
Jsont.Object.map ~kind:"UserOutgoingMessage" (fun _role json_content ->
86
+
let content = decode_content json_content in
87
+
{ content; unknown = Unknown.empty })
88
+
|> Jsont.Object.mem "role" Jsont.string ~enc:(fun _ -> "user")
89
+
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t ->
90
+
encode_content (content t))
91
+
|> Jsont.Object.finish
92
+
in
93
+
Jsont.Object.map ~kind:"UserOutgoingEnvelope" Fun.id
94
+
|> Jsont.Object.mem "message" message_jsont ~enc:Fun.id
95
+
|> Jsont.Object.finish
96
+
97
+
let to_json t =
98
+
match Jsont.Json.encode jsont t with
99
+
| Ok json -> json
100
+
| Error e -> invalid_arg ("User.to_json: " ^ e)
101
+
end
102
+
103
+
module Assistant = struct
104
+
type error =
105
+
[ `Authentication_failed
106
+
| `Billing_error
107
+
| `Rate_limit
108
+
| `Invalid_request
109
+
| `Server_error
110
+
| `Unknown ]
111
+
112
+
let error_jsont : error Jsont.t =
113
+
Jsont.enum
114
+
[
115
+
("authentication_failed", `Authentication_failed);
116
+
("billing_error", `Billing_error);
117
+
("rate_limit", `Rate_limit);
118
+
("invalid_request", `Invalid_request);
119
+
("server_error", `Server_error);
120
+
("unknown", `Unknown);
121
+
]
122
+
123
+
type t = {
124
+
content : Content_block.t list;
125
+
model : string;
126
+
error : error option;
127
+
unknown : Unknown.t;
128
+
}
129
+
130
+
let create ~content ~model ?error () =
131
+
{ content; model; error; unknown = Unknown.empty }
132
+
133
+
let make content model error unknown = { content; model; error; unknown }
134
+
let content t = t.content
135
+
let model t = t.model
136
+
let error t = t.error
137
+
let unknown t = t.unknown
138
+
139
+
let text_blocks t =
140
+
List.filter_map
141
+
(function
142
+
| Content_block.Text text -> Some (Content_block.Text.text text)
143
+
| _ -> None)
144
+
t.content
145
+
146
+
let tool_uses t =
147
+
List.filter_map
148
+
(function Content_block.Tool_use tool -> Some tool | _ -> None)
149
+
t.content
150
+
151
+
let thinking_blocks t =
152
+
List.filter_map
153
+
(function Content_block.Thinking thinking -> Some thinking | _ -> None)
154
+
t.content
155
+
156
+
let has_tool_use t =
157
+
List.exists
158
+
(function Content_block.Tool_use _ -> true | _ -> false)
159
+
t.content
160
+
161
+
let combined_text t = String.concat "\n" (text_blocks t)
162
+
163
+
let jsont : t Jsont.t =
164
+
Jsont.Object.map ~kind:"Assistant" make
165
+
|> Jsont.Object.mem "content" (Jsont.list Content_block.jsont) ~enc:content
166
+
|> Jsont.Object.mem "model" Jsont.string ~enc:model
167
+
|> Jsont.Object.opt_mem "error" error_jsont ~enc:error
168
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
169
+
|> Jsont.Object.finish
170
+
171
+
let incoming_jsont : t Jsont.t =
172
+
Jsont.Object.map ~kind:"AssistantEnvelope" Fun.id
173
+
|> Jsont.Object.mem "message" jsont ~enc:Fun.id
174
+
|> Jsont.Object.finish
175
+
176
+
let to_json t =
177
+
match Jsont.Json.encode jsont t with
178
+
| Ok json -> json
179
+
| Error e -> invalid_arg ("Assistant.to_json: " ^ e)
180
+
end
181
+
182
+
module System = struct
183
+
type init = {
184
+
session_id : string option;
185
+
model : string option;
186
+
cwd : string option;
187
+
unknown : Unknown.t;
188
+
}
189
+
190
+
type error = { error : string; unknown : Unknown.t }
191
+
type t = Init of init | Error of error
192
+
193
+
let is_init = function Init _ -> true | _ -> false
194
+
let is_error = function Error _ -> true | _ -> false
195
+
let session_id = function Init i -> i.session_id | _ -> None
196
+
let model = function Init i -> i.model | _ -> None
197
+
let cwd = function Init i -> i.cwd | _ -> None
198
+
let error_message = function Error e -> Some e.error | _ -> None
199
+
let error_msg = error_message
200
+
let unknown = function Init i -> i.unknown | Error e -> e.unknown
201
+
202
+
let init ?session_id ?model ?cwd () =
203
+
Init { session_id; model; cwd; unknown = Unknown.empty }
204
+
205
+
let error ~error = Error { error; unknown = Unknown.empty }
206
+
207
+
let init_jsont : init Jsont.t =
208
+
let make session_id model cwd unknown : init =
209
+
{ session_id; model; cwd; unknown }
210
+
in
211
+
Jsont.Object.map ~kind:"SystemInit" make
212
+
|> Jsont.Object.opt_mem "session_id" Jsont.string ~enc:(fun (r : init) ->
213
+
r.session_id)
214
+
|> Jsont.Object.opt_mem "model" Jsont.string ~enc:(fun (r : init) ->
215
+
r.model)
216
+
|> Jsont.Object.opt_mem "cwd" Jsont.string ~enc:(fun (r : init) -> r.cwd)
217
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : init) -> r.unknown)
218
+
|> Jsont.Object.finish
219
+
220
+
let error_jsont : error Jsont.t =
221
+
let make err unknown : error = { error = err; unknown } in
222
+
Jsont.Object.map ~kind:"SystemError" make
223
+
|> Jsont.Object.mem "error" Jsont.string ~enc:(fun (r : error) -> r.error)
224
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(fun (r : error) ->
225
+
r.unknown)
226
+
|> Jsont.Object.finish
227
+
228
+
let jsont : t Jsont.t =
229
+
let case_init =
230
+
Jsont.Object.Case.map "init" init_jsont ~dec:(fun v -> Init v)
231
+
in
232
+
let case_error =
233
+
Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
234
+
in
235
+
let enc_case = function
236
+
| Init v -> Jsont.Object.Case.value case_init v
237
+
| Error v -> Jsont.Object.Case.value case_error v
238
+
in
239
+
let cases = Jsont.Object.Case.[ make case_init; make case_error ] in
240
+
Jsont.Object.map ~kind:"System" Fun.id
241
+
|> Jsont.Object.case_mem "subtype" Jsont.string ~enc:Fun.id ~enc_case cases
242
+
~tag_to_string:Fun.id ~tag_compare:String.compare
243
+
|> Jsont.Object.finish
244
+
245
+
let to_json t =
246
+
match Jsont.Json.encode jsont t with
247
+
| Ok json -> json
248
+
| Error e -> invalid_arg ("System.to_json: " ^ e)
249
+
end
250
+
251
+
module Result = struct
252
+
module Usage = struct
253
+
type t = {
254
+
input_tokens : int option;
255
+
output_tokens : int option;
256
+
total_tokens : int option;
257
+
cache_creation_input_tokens : int option;
258
+
cache_read_input_tokens : int option;
259
+
unknown : Unknown.t;
260
+
}
261
+
262
+
let make input_tokens output_tokens total_tokens cache_creation_input_tokens
263
+
cache_read_input_tokens unknown =
264
+
{
265
+
input_tokens;
266
+
output_tokens;
267
+
total_tokens;
268
+
cache_creation_input_tokens;
269
+
cache_read_input_tokens;
270
+
unknown;
271
+
}
272
+
273
+
let create ?input_tokens ?output_tokens ?total_tokens
274
+
?cache_creation_input_tokens ?cache_read_input_tokens () =
275
+
{
276
+
input_tokens;
277
+
output_tokens;
278
+
total_tokens;
279
+
cache_creation_input_tokens;
280
+
cache_read_input_tokens;
281
+
unknown = Unknown.empty;
282
+
}
283
+
284
+
let input_tokens t = t.input_tokens
285
+
let output_tokens t = t.output_tokens
286
+
let total_tokens t = t.total_tokens
287
+
let cache_creation_input_tokens t = t.cache_creation_input_tokens
288
+
let cache_read_input_tokens t = t.cache_read_input_tokens
289
+
let unknown t = t.unknown
290
+
291
+
let jsont : t Jsont.t =
292
+
Jsont.Object.map ~kind:"Usage" make
293
+
|> Jsont.Object.opt_mem "input_tokens" Jsont.int ~enc:input_tokens
294
+
|> Jsont.Object.opt_mem "output_tokens" Jsont.int ~enc:output_tokens
295
+
|> Jsont.Object.opt_mem "total_tokens" Jsont.int ~enc:total_tokens
296
+
|> Jsont.Object.opt_mem "cache_creation_input_tokens" Jsont.int
297
+
~enc:cache_creation_input_tokens
298
+
|> Jsont.Object.opt_mem "cache_read_input_tokens" Jsont.int
299
+
~enc:cache_read_input_tokens
300
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
301
+
|> Jsont.Object.finish
302
+
end
303
+
304
+
type t = {
305
+
subtype : string;
306
+
duration_ms : int;
307
+
duration_api_ms : int;
308
+
is_error : bool;
309
+
num_turns : int;
310
+
session_id : string;
311
+
total_cost_usd : float option;
312
+
usage : Usage.t option;
313
+
result : string option;
314
+
structured_output : Jsont.json option;
315
+
unknown : Unknown.t;
316
+
}
317
+
318
+
let create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
319
+
~session_id ?total_cost_usd ?usage ?result ?structured_output () =
320
+
{
321
+
subtype;
322
+
duration_ms;
323
+
duration_api_ms;
324
+
is_error;
325
+
num_turns;
326
+
session_id;
327
+
total_cost_usd;
328
+
usage;
329
+
result;
330
+
structured_output;
331
+
unknown = Unknown.empty;
332
+
}
333
+
334
+
let make subtype duration_ms duration_api_ms is_error num_turns session_id
335
+
total_cost_usd usage result structured_output unknown =
336
+
{
337
+
subtype;
338
+
duration_ms;
339
+
duration_api_ms;
340
+
is_error;
341
+
num_turns;
342
+
session_id;
343
+
total_cost_usd;
344
+
usage;
345
+
result;
346
+
structured_output;
347
+
unknown;
348
+
}
349
+
350
+
let subtype t = t.subtype
351
+
let duration_ms t = t.duration_ms
352
+
let duration_api_ms t = t.duration_api_ms
353
+
let is_error t = t.is_error
354
+
let num_turns t = t.num_turns
355
+
let session_id t = t.session_id
356
+
let total_cost_usd t = t.total_cost_usd
357
+
let usage t = t.usage
358
+
let result t = t.result
359
+
let result_text = result
360
+
let structured_output t = t.structured_output
361
+
let unknown t = t.unknown
362
+
363
+
let jsont : t Jsont.t =
364
+
Jsont.Object.map ~kind:"Result" make
365
+
|> Jsont.Object.mem "subtype" Jsont.string ~enc:subtype
366
+
|> Jsont.Object.mem "duration_ms" Jsont.int ~enc:duration_ms
367
+
|> Jsont.Object.mem "duration_api_ms" Jsont.int ~enc:duration_api_ms
368
+
|> Jsont.Object.mem "is_error" Jsont.bool ~enc:is_error
369
+
|> Jsont.Object.mem "num_turns" Jsont.int ~enc:num_turns
370
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:session_id
371
+
|> Jsont.Object.opt_mem "total_cost_usd" Jsont.number ~enc:total_cost_usd
372
+
|> Jsont.Object.opt_mem "usage" Usage.jsont ~enc:usage
373
+
|> Jsont.Object.opt_mem "result" Jsont.string ~enc:result
374
+
|> Jsont.Object.opt_mem "structured_output" Jsont.json
375
+
~enc:structured_output
376
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
377
+
|> Jsont.Object.finish
378
+
379
+
let to_json t =
380
+
match Jsont.Json.encode jsont t with
381
+
| Ok json -> json
382
+
| Error e -> invalid_arg ("Result.to_json: " ^ e)
383
+
end
384
+
385
+
type t =
386
+
| User of User.t
387
+
| Assistant of Assistant.t
388
+
| System of System.t
389
+
| Result of Result.t
390
+
391
+
let jsont : t Jsont.t =
392
+
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
393
+
let case_user = case_map "user" User.incoming_jsont (fun v -> User v) in
394
+
let case_assistant =
395
+
case_map "assistant" Assistant.incoming_jsont (fun v -> Assistant v)
396
+
in
397
+
let case_system = case_map "system" System.jsont (fun v -> System v) in
398
+
let case_result = case_map "result" Result.jsont (fun v -> Result v) in
399
+
let enc_case = function
400
+
| User v -> Jsont.Object.Case.value case_user v
401
+
| Assistant v -> Jsont.Object.Case.value case_assistant v
402
+
| System v -> Jsont.Object.Case.value case_system v
403
+
| Result v -> Jsont.Object.Case.value case_result v
404
+
in
405
+
let cases =
406
+
Jsont.Object.Case.
407
+
[
408
+
make case_user; make case_assistant; make case_system; make case_result;
409
+
]
410
+
in
411
+
Jsont.Object.map ~kind:"Message" Fun.id
412
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
413
+
~tag_to_string:Fun.id ~tag_compare:String.compare
414
+
|> Jsont.Object.finish
415
+
416
+
let is_user = function User _ -> true | _ -> false
417
+
let is_assistant = function Assistant _ -> true | _ -> false
418
+
let is_system = function System _ -> true | _ -> false
419
+
let is_result = function Result _ -> true | _ -> false
420
+
421
+
let is_error = function
422
+
| Result r -> Result.is_error r
423
+
| System s -> System.is_error s
424
+
| _ -> false
425
+
426
+
let extract_text = function
427
+
| User u -> User.as_text u
428
+
| Assistant a ->
429
+
let text = Assistant.combined_text a in
430
+
if text = "" then None else Some text
431
+
| _ -> None
432
+
433
+
let extract_tool_uses = function
434
+
| Assistant a -> Assistant.tool_uses a
435
+
| _ -> []
436
+
437
+
let session_id = function
438
+
| System s -> System.session_id s
439
+
| Result r -> Some (Result.session_id r)
440
+
| _ -> None
441
+
442
+
let to_json = function
443
+
| User u -> User.to_json u
444
+
| Assistant a -> Assistant.to_json a
445
+
| System s -> System.to_json s
446
+
| Result r -> Result.to_json r
447
+
448
+
let user_string s = User (User.of_string s)
449
+
let user_blocks blocks = User (User.of_blocks blocks)
450
+
let pp ppf t = Jsont.pp_value jsont () ppf t
451
+
let log_received t = Log.info (fun m -> m "<- %a" pp t)
452
+
let log_sending t = Log.info (fun m -> m "-> %a" pp t)
+192
lib/message.mli
+192
lib/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. *)
7
+
8
+
val src : Logs.Src.t
9
+
(** The log source for message operations. *)
10
+
11
+
(** {1 User Messages} *)
12
+
13
+
module User : sig
14
+
type content = String of string | Blocks of Content_block.t list
15
+
type t
16
+
17
+
val of_string : string -> t
18
+
(** [of_string s] creates a user message with simple text content. *)
19
+
20
+
val of_blocks : Content_block.t list -> t
21
+
(** [of_blocks blocks] creates a user message with content blocks. *)
22
+
23
+
val with_tool_result :
24
+
tool_use_id:string -> content:Jsont.json -> ?is_error:bool -> unit -> t
25
+
(** [with_tool_result ~tool_use_id ~content ?is_error ()] creates a user
26
+
message containing a tool result. Content can be a string or array. *)
27
+
28
+
val content : t -> content
29
+
val unknown : t -> Unknown.t
30
+
31
+
val as_text : t -> string option
32
+
(** [as_text t] returns the text content if the message is a simple string,
33
+
None otherwise. *)
34
+
35
+
val blocks : t -> Content_block.t list
36
+
(** [blocks t] returns the content blocks, or a single text block if it's a
37
+
string message. *)
38
+
39
+
val jsont : t Jsont.t
40
+
val incoming_jsont : t Jsont.t
41
+
val outgoing_jsont : t Jsont.t
42
+
val to_json : t -> Jsont.json
43
+
end
44
+
45
+
(** {1 Assistant Messages} *)
46
+
47
+
module Assistant : sig
48
+
type error =
49
+
[ `Authentication_failed
50
+
| `Billing_error
51
+
| `Rate_limit
52
+
| `Invalid_request
53
+
| `Server_error
54
+
| `Unknown ]
55
+
56
+
type t
57
+
58
+
val create :
59
+
content:Content_block.t list -> model:string -> ?error:error -> unit -> t
60
+
61
+
val content : t -> Content_block.t list
62
+
val model : t -> string
63
+
val error : t -> error option
64
+
val unknown : t -> Unknown.t
65
+
val text_blocks : t -> string list
66
+
val tool_uses : t -> Content_block.Tool_use.t list
67
+
val thinking_blocks : t -> Content_block.Thinking.t list
68
+
val combined_text : t -> string
69
+
val has_tool_use : t -> bool
70
+
val jsont : t Jsont.t
71
+
val incoming_jsont : t Jsont.t
72
+
val to_json : t -> Jsont.json
73
+
end
74
+
75
+
(** {1 System Messages} *)
76
+
77
+
module System : sig
78
+
type init = {
79
+
session_id : string option;
80
+
model : string option;
81
+
cwd : string option;
82
+
unknown : Unknown.t;
83
+
}
84
+
85
+
type error = { error : string; unknown : Unknown.t }
86
+
type t = Init of init | Error of error
87
+
88
+
val is_init : t -> bool
89
+
val is_error : t -> bool
90
+
val session_id : t -> string option
91
+
val model : t -> string option
92
+
val cwd : t -> string option
93
+
val error_message : t -> string option
94
+
val error_msg : t -> string option
95
+
val unknown : t -> Unknown.t
96
+
val init : ?session_id:string -> ?model:string -> ?cwd:string -> unit -> t
97
+
val error : error:string -> t
98
+
val jsont : t Jsont.t
99
+
val to_json : t -> Jsont.json
100
+
end
101
+
102
+
(** {1 Result Messages} *)
103
+
104
+
module Result : sig
105
+
module Usage : sig
106
+
type t
107
+
108
+
val create :
109
+
?input_tokens:int ->
110
+
?output_tokens:int ->
111
+
?total_tokens:int ->
112
+
?cache_creation_input_tokens:int ->
113
+
?cache_read_input_tokens:int ->
114
+
unit ->
115
+
t
116
+
117
+
val input_tokens : t -> int option
118
+
val output_tokens : t -> int option
119
+
val total_tokens : t -> int option
120
+
val cache_creation_input_tokens : t -> int option
121
+
val cache_read_input_tokens : t -> int option
122
+
val unknown : t -> Unknown.t
123
+
val jsont : t Jsont.t
124
+
end
125
+
126
+
type t
127
+
128
+
val create :
129
+
subtype:string ->
130
+
duration_ms:int ->
131
+
duration_api_ms:int ->
132
+
is_error:bool ->
133
+
num_turns:int ->
134
+
session_id:string ->
135
+
?total_cost_usd:float ->
136
+
?usage:Usage.t ->
137
+
?result:string ->
138
+
?structured_output:Jsont.json ->
139
+
unit ->
140
+
t
141
+
142
+
val subtype : t -> string
143
+
val duration_ms : t -> int
144
+
val duration_api_ms : t -> int
145
+
val is_error : t -> bool
146
+
val num_turns : t -> int
147
+
val session_id : t -> string
148
+
val total_cost_usd : t -> float option
149
+
val usage : t -> Usage.t option
150
+
val result : t -> string option
151
+
val result_text : t -> string option
152
+
val structured_output : t -> Jsont.json option
153
+
val unknown : t -> Unknown.t
154
+
val jsont : t Jsont.t
155
+
val to_json : t -> Jsont.json
156
+
end
157
+
158
+
(** {1 Message Union Type} *)
159
+
160
+
type t =
161
+
| User of User.t
162
+
| Assistant of Assistant.t
163
+
| System of System.t
164
+
| Result of Result.t
165
+
166
+
val jsont : t Jsont.t
167
+
168
+
(** {1 Internal - wire format conversion} *)
169
+
170
+
val to_json : t -> Jsont.json
171
+
172
+
(** {1 Convenience Constructors} *)
173
+
174
+
val user_string : string -> t
175
+
val user_blocks : Content_block.t list -> t
176
+
177
+
(** {1 Message Analysis} *)
178
+
179
+
val is_user : t -> bool
180
+
val is_assistant : t -> bool
181
+
val is_system : t -> bool
182
+
val is_result : t -> bool
183
+
val is_error : t -> bool
184
+
val extract_text : t -> string option
185
+
val extract_tool_uses : t -> Content_block.Tool_use.t list
186
+
val session_id : t -> string option
187
+
188
+
(** {1 Logging} *)
189
+
190
+
val pp : Format.formatter -> t -> unit
191
+
val log_received : t -> unit
192
+
val log_sending : t -> unit
+48
lib/model.ml
+48
lib/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_6
8
+
| `Sonnet_4_5
9
+
| `Sonnet_4
10
+
| `Sonnet_3_5
11
+
| `Opus_4_6
12
+
| `Opus_4_5
13
+
| `Opus_4_1
14
+
| `Opus_4
15
+
| `Haiku_4_5
16
+
| `Haiku_4
17
+
| `Custom of string ]
18
+
19
+
let to_string = function
20
+
| `Sonnet_4_6 -> "claude-sonnet-4-6"
21
+
| `Sonnet_4_5 -> "claude-sonnet-4-5"
22
+
| `Sonnet_4 -> "claude-sonnet-4"
23
+
| `Sonnet_3_5 -> "claude-sonnet-3-5"
24
+
| `Opus_4_6 -> "claude-opus-4-6"
25
+
| `Opus_4_5 -> "claude-opus-4-5"
26
+
| `Opus_4_1 -> "claude-opus-4-1"
27
+
| `Opus_4 -> "claude-opus-4"
28
+
| `Haiku_4_5 -> "claude-haiku-4-5"
29
+
| `Haiku_4 -> "claude-haiku-4"
30
+
| `Custom s -> s
31
+
32
+
let pp ppf t = Format.pp_print_string ppf (to_string t)
33
+
34
+
let of_string = function
35
+
| "claude-sonnet-4-6" | "sonnet" -> `Sonnet_4_6
36
+
| "claude-sonnet-4-5" -> `Sonnet_4_5
37
+
| "claude-sonnet-4" -> `Sonnet_4
38
+
| "claude-sonnet-3-5" -> `Sonnet_3_5
39
+
| "claude-opus-4-6" | "opus" -> `Opus_4_6
40
+
| "claude-opus-4-5" -> `Opus_4_5
41
+
| "claude-opus-4-1" -> `Opus_4_1
42
+
| "claude-opus-4" -> `Opus_4
43
+
| "claude-haiku-4-5" | "haiku" -> `Haiku_4_5
44
+
| "claude-haiku-4" -> `Haiku_4
45
+
| s -> `Custom s
46
+
47
+
let jsont : t Jsont.t =
48
+
Jsont.map ~kind:"Model" ~dec:of_string ~enc:to_string Jsont.string
+50
lib/model.mli
+50
lib/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.
7
+
8
+
This module provides type-safe model identifiers based on the Python SDK's
9
+
model strings. Use polymorphic variants for known models with a custom
10
+
escape hatch for future or unknown models. *)
11
+
12
+
type t =
13
+
[ `Sonnet_4_6 (** claude-sonnet-4-6 - Most recent Sonnet model *)
14
+
| `Sonnet_4_5 (** claude-sonnet-4-5 - Sonnet 4.5 model *)
15
+
| `Sonnet_4 (** claude-sonnet-4 - Sonnet 4 model *)
16
+
| `Sonnet_3_5 (** claude-sonnet-3-5 - Sonnet 3.5 model *)
17
+
| `Opus_4_6 (** claude-opus-4-6 - Most recent Opus model *)
18
+
| `Opus_4_5 (** claude-opus-4-5 - Opus 4.5 model *)
19
+
| `Opus_4_1 (** claude-opus-4-1 - Opus 4.1 model *)
20
+
| `Opus_4 (** claude-opus-4 - Opus 4 model for complex tasks *)
21
+
| `Haiku_4_5 (** claude-haiku-4-5 - Most recent Haiku model *)
22
+
| `Haiku_4 (** claude-haiku-4 - Haiku 4 model *)
23
+
| `Custom of string (** Custom model string for future/unknown models *) ]
24
+
(** The type of Claude models. *)
25
+
26
+
val pp : Format.formatter -> t -> unit
27
+
(** [pp ppf t] pretty-prints the model identifier. *)
28
+
29
+
val to_string : t -> string
30
+
(** [to_string t] converts a model to its CLI string representation.
31
+
32
+
Examples:
33
+
- [`Sonnet_4_6] becomes "claude-sonnet-4-6"
34
+
- [`Opus_4_6] becomes "claude-opus-4-6"
35
+
- [`Haiku_4_5] becomes "claude-haiku-4-5"
36
+
- [`Custom "my-model"] becomes "my-model". *)
37
+
38
+
val of_string : string -> t
39
+
(** [of_string s] parses a model string into a typed model.
40
+
41
+
Known model strings are converted to their typed variants. Unknown strings
42
+
become [`Custom s].
43
+
44
+
Examples:
45
+
- "claude-sonnet-4-6" or "sonnet" becomes [`Sonnet_4_6].
46
+
- "claude-opus-4-6" or "opus" becomes [`Opus_4_6].
47
+
- "future-model" becomes [`Custom "future-model"]. *)
48
+
49
+
val jsont : t Jsont.t
50
+
(** [jsont] is the Jsont codec for model identifiers. *)
+362
lib/options.ml
+362
lib/options.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let src = Logs.Src.create "claude.options" ~doc:"Claude configuration options"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
module Wire = struct
11
+
type setting_source = User | Project | Local
12
+
13
+
let setting_source_jsont : setting_source Jsont.t =
14
+
Jsont.enum [ ("user", User); ("project", Project); ("local", Local) ]
15
+
16
+
type t = {
17
+
allowed_tools : string list;
18
+
disallowed_tools : string list;
19
+
max_thinking_tokens : int option;
20
+
system_prompt : string option;
21
+
append_system_prompt : string option;
22
+
permission_mode : Permissions.Mode.t option;
23
+
model : Model.t option;
24
+
continue_conversation : bool;
25
+
resume : string option;
26
+
max_turns : int option;
27
+
permission_prompt_tool_name : string option;
28
+
settings : string option;
29
+
add_dirs : string list;
30
+
max_budget_usd : float option;
31
+
fallback_model : Model.t option;
32
+
setting_sources : setting_source list option;
33
+
max_buffer_size : int option;
34
+
user : string option;
35
+
output_format : Structured_output.t option;
36
+
unknown : Unknown.t;
37
+
}
38
+
39
+
let empty =
40
+
{
41
+
allowed_tools = [];
42
+
disallowed_tools = [];
43
+
max_thinking_tokens = None;
44
+
system_prompt = None;
45
+
append_system_prompt = None;
46
+
permission_mode = None;
47
+
model = None;
48
+
continue_conversation = false;
49
+
resume = None;
50
+
max_turns = None;
51
+
permission_prompt_tool_name = None;
52
+
settings = None;
53
+
add_dirs = [];
54
+
max_budget_usd = None;
55
+
fallback_model = None;
56
+
setting_sources = None;
57
+
max_buffer_size = None;
58
+
user = None;
59
+
output_format = None;
60
+
unknown = Unknown.empty;
61
+
}
62
+
63
+
let allowed_tools t = t.allowed_tools
64
+
let disallowed_tools t = t.disallowed_tools
65
+
let max_thinking_tokens t = t.max_thinking_tokens
66
+
let system_prompt t = t.system_prompt
67
+
let append_system_prompt t = t.append_system_prompt
68
+
let permission_mode t = t.permission_mode
69
+
let model t = t.model
70
+
let continue_conversation t = t.continue_conversation
71
+
let resume t = t.resume
72
+
let max_turns t = t.max_turns
73
+
let permission_prompt_tool_name t = t.permission_prompt_tool_name
74
+
let settings t = t.settings
75
+
let add_dirs t = t.add_dirs
76
+
let max_budget_usd t = t.max_budget_usd
77
+
let fallback_model t = t.fallback_model
78
+
let setting_sources t = t.setting_sources
79
+
let max_buffer_size t = t.max_buffer_size
80
+
let user t = t.user
81
+
let output_format t = t.output_format
82
+
let unknown t = t.unknown
83
+
let with_allowed_tools allowed_tools t = { t with allowed_tools }
84
+
let with_disallowed_tools disallowed_tools t = { t with disallowed_tools }
85
+
86
+
let with_max_thinking_tokens max_thinking_tokens t =
87
+
{ t with max_thinking_tokens = Some max_thinking_tokens }
88
+
89
+
let with_system_prompt system_prompt t =
90
+
{ t with system_prompt = Some system_prompt }
91
+
92
+
let with_append_system_prompt append_system_prompt t =
93
+
{ t with append_system_prompt = Some append_system_prompt }
94
+
95
+
let with_permission_mode permission_mode t =
96
+
{ t with permission_mode = Some permission_mode }
97
+
98
+
let with_model model t = { t with model = Some model }
99
+
100
+
let with_continue_conversation continue_conversation t =
101
+
{ t with continue_conversation }
102
+
103
+
let with_resume resume t = { t with resume = Some resume }
104
+
let with_max_turns max_turns t = { t with max_turns = Some max_turns }
105
+
106
+
let with_permission_prompt_tool_name permission_prompt_tool_name t =
107
+
{ t with permission_prompt_tool_name = Some permission_prompt_tool_name }
108
+
109
+
let with_settings settings t = { t with settings = Some settings }
110
+
let with_add_dirs add_dirs t = { t with add_dirs }
111
+
112
+
let with_max_budget_usd max_budget_usd t =
113
+
{ t with max_budget_usd = Some max_budget_usd }
114
+
115
+
let with_fallback_model fallback_model t =
116
+
{ t with fallback_model = Some fallback_model }
117
+
118
+
let with_setting_sources setting_sources t =
119
+
{ t with setting_sources = Some setting_sources }
120
+
121
+
let with_max_buffer_size max_buffer_size t =
122
+
{ t with max_buffer_size = Some max_buffer_size }
123
+
124
+
let with_user user t = { t with user = Some user }
125
+
126
+
let with_output_format output_format t =
127
+
{ t with output_format = Some output_format }
128
+
129
+
let jsont : t Jsont.t =
130
+
let make allowed_tools disallowed_tools max_thinking_tokens system_prompt
131
+
append_system_prompt permission_mode model continue_conversation resume
132
+
max_turns permission_prompt_tool_name settings add_dirs max_budget_usd
133
+
fallback_model setting_sources max_buffer_size user output_format
134
+
unknown =
135
+
{
136
+
allowed_tools;
137
+
disallowed_tools;
138
+
max_thinking_tokens;
139
+
system_prompt;
140
+
append_system_prompt;
141
+
permission_mode;
142
+
model;
143
+
continue_conversation;
144
+
resume;
145
+
max_turns;
146
+
permission_prompt_tool_name;
147
+
settings;
148
+
add_dirs;
149
+
max_budget_usd;
150
+
fallback_model;
151
+
setting_sources;
152
+
max_buffer_size;
153
+
user;
154
+
output_format;
155
+
unknown;
156
+
}
157
+
in
158
+
Jsont.Object.(
159
+
map ~kind:"Options" make
160
+
|> mem "allowedTools" (Jsont.list Jsont.string) ~enc:allowed_tools
161
+
~dec_absent:[]
162
+
|> mem "disallowedTools" (Jsont.list Jsont.string) ~enc:disallowed_tools
163
+
~dec_absent:[]
164
+
|> opt_mem "maxThinkingTokens" Jsont.int ~enc:max_thinking_tokens
165
+
|> opt_mem "systemPrompt" Jsont.string ~enc:system_prompt
166
+
|> opt_mem "appendSystemPrompt" Jsont.string ~enc:append_system_prompt
167
+
|> opt_mem "permissionMode" Permissions.Mode.jsont ~enc:permission_mode
168
+
|> opt_mem "model" Model.jsont ~enc:model
169
+
|> mem "continueConversation" Jsont.bool ~enc:continue_conversation
170
+
~dec_absent:false
171
+
|> opt_mem "resume" Jsont.string ~enc:resume
172
+
|> opt_mem "maxTurns" Jsont.int ~enc:max_turns
173
+
|> opt_mem "permissionPromptToolName" Jsont.string
174
+
~enc:permission_prompt_tool_name
175
+
|> opt_mem "settings" Jsont.string ~enc:settings
176
+
|> mem "addDirs" (Jsont.list Jsont.string) ~enc:add_dirs ~dec_absent:[]
177
+
|> opt_mem "maxBudgetUsd" Jsont.number ~enc:max_budget_usd
178
+
|> opt_mem "fallbackModel" Model.jsont ~enc:fallback_model
179
+
|> opt_mem "settingSources"
180
+
(Jsont.list setting_source_jsont)
181
+
~enc:setting_sources
182
+
|> opt_mem "maxBufferSize" Jsont.int ~enc:max_buffer_size
183
+
|> opt_mem "user" Jsont.string ~enc:user
184
+
|> opt_mem "outputFormat" Structured_output.jsont ~enc:output_format
185
+
|> keep_unknown Unknown.mems ~enc:unknown
186
+
|> finish)
187
+
188
+
let pp ppf t = Jsont.pp_value jsont () ppf t
189
+
end
190
+
191
+
type t = {
192
+
allowed_tools : string list;
193
+
disallowed_tools : string list;
194
+
max_thinking_tokens : int;
195
+
system_prompt : string option;
196
+
append_system_prompt : string option;
197
+
permission_mode : Permissions.Mode.t option;
198
+
permission_callback : Permissions.callback option;
199
+
model : Model.t option;
200
+
cwd : Eio.Fs.dir_ty Eio.Path.t option;
201
+
env : (string * string) list;
202
+
continue_conversation : bool;
203
+
resume : string option;
204
+
max_turns : int option;
205
+
permission_prompt_tool_name : string option;
206
+
settings : string option;
207
+
add_dirs : string list;
208
+
extra_args : (string * string option) list;
209
+
debug_stderr : Eio.Flow.sink_ty Eio.Flow.sink option;
210
+
hooks : Hooks.t option;
211
+
max_budget_usd : float option;
212
+
fallback_model : Model.t option;
213
+
setting_sources : Wire.setting_source list option;
214
+
max_buffer_size : int option;
215
+
user : string option;
216
+
output_format : Structured_output.t option;
217
+
mcp_servers : (string * Mcp_server.t) list;
218
+
}
219
+
220
+
let default =
221
+
{
222
+
allowed_tools = [];
223
+
disallowed_tools = [];
224
+
max_thinking_tokens = 8000;
225
+
system_prompt = None;
226
+
append_system_prompt = None;
227
+
permission_mode = None;
228
+
permission_callback = Some Permissions.default_allow;
229
+
model = None;
230
+
cwd = None;
231
+
env = [];
232
+
continue_conversation = false;
233
+
resume = None;
234
+
max_turns = None;
235
+
permission_prompt_tool_name = None;
236
+
settings = None;
237
+
add_dirs = [];
238
+
extra_args = [];
239
+
debug_stderr = None;
240
+
hooks = None;
241
+
max_budget_usd = None;
242
+
fallback_model = None;
243
+
setting_sources = None;
244
+
max_buffer_size = None;
245
+
user = None;
246
+
output_format = None;
247
+
mcp_servers = [];
248
+
}
249
+
250
+
(* Accessors *)
251
+
let allowed_tools t = t.allowed_tools
252
+
let disallowed_tools t = t.disallowed_tools
253
+
let max_thinking_tokens t = t.max_thinking_tokens
254
+
let system_prompt t = t.system_prompt
255
+
let append_system_prompt t = t.append_system_prompt
256
+
let permission_mode t = t.permission_mode
257
+
let permission_callback t = t.permission_callback
258
+
let model t = t.model
259
+
let cwd t = t.cwd
260
+
let env t = t.env
261
+
let continue_conversation t = t.continue_conversation
262
+
let resume t = t.resume
263
+
let max_turns t = t.max_turns
264
+
let permission_prompt_tool_name t = t.permission_prompt_tool_name
265
+
let settings t = t.settings
266
+
let add_dirs t = t.add_dirs
267
+
let extra_args t = t.extra_args
268
+
let debug_stderr t = t.debug_stderr
269
+
let hooks t = t.hooks
270
+
let max_budget_usd t = t.max_budget_usd
271
+
let fallback_model t = t.fallback_model
272
+
let setting_sources t = t.setting_sources
273
+
let max_buffer_size t = t.max_buffer_size
274
+
let user t = t.user
275
+
let output_format t = t.output_format
276
+
let mcp_servers t = t.mcp_servers
277
+
278
+
(* Builders *)
279
+
let with_allowed_tools tools t = { t with allowed_tools = tools }
280
+
let with_disallowed_tools tools t = { t with disallowed_tools = tools }
281
+
let with_max_thinking_tokens tokens t = { t with max_thinking_tokens = tokens }
282
+
let with_system_prompt prompt t = { t with system_prompt = Some prompt }
283
+
284
+
let with_append_system_prompt prompt t =
285
+
{ t with append_system_prompt = Some prompt }
286
+
287
+
let with_permission_mode mode t = { t with permission_mode = Some mode }
288
+
289
+
let with_permission_callback callback t =
290
+
{ t with permission_callback = Some callback }
291
+
292
+
let with_model model t = { t with model = Some model }
293
+
let with_cwd cwd t = { t with cwd = Some (cwd :> Eio.Fs.dir_ty Eio.Path.t) }
294
+
let with_env env t = { t with env }
295
+
296
+
let with_continue_conversation continue t =
297
+
{ t with continue_conversation = continue }
298
+
299
+
let with_resume session_id t = { t with resume = Some session_id }
300
+
let with_max_turns turns t = { t with max_turns = Some turns }
301
+
302
+
let with_permission_prompt_tool_name tool t =
303
+
{ t with permission_prompt_tool_name = Some tool }
304
+
305
+
let with_settings path t = { t with settings = Some path }
306
+
let with_add_dirs dirs t = { t with add_dirs = dirs }
307
+
let with_extra_args args t = { t with extra_args = args }
308
+
309
+
let with_debug_stderr sink t =
310
+
{ t with debug_stderr = Some (sink :> Eio.Flow.sink_ty Eio.Flow.sink) }
311
+
312
+
let with_hooks hooks t = { t with hooks = Some hooks }
313
+
let with_max_budget_usd budget t = { t with max_budget_usd = Some budget }
314
+
let with_fallback_model model t = { t with fallback_model = Some model }
315
+
let with_no_settings t = { t with setting_sources = Some [] }
316
+
let with_max_buffer_size size t = { t with max_buffer_size = Some size }
317
+
let with_user user t = { t with user = Some user }
318
+
let with_output_format format t = { t with output_format = Some format }
319
+
320
+
let with_mcp_server ~name server t =
321
+
{ t with mcp_servers = (name, server) :: t.mcp_servers }
322
+
323
+
let log_options t =
324
+
Log.debug (fun m ->
325
+
m "Options: model=%s fallback=%s max_thinking_tokens=%d max_budget=%s"
326
+
(match t.model with None -> "default" | Some m -> Model.to_string m)
327
+
(match t.fallback_model with
328
+
| None -> "none"
329
+
| Some m -> Model.to_string m)
330
+
t.max_thinking_tokens
331
+
(match t.max_budget_usd with
332
+
| None -> "unlimited"
333
+
| Some b -> Fmt.str "$%.2f" b))
334
+
335
+
module Advanced = struct
336
+
let apply_opt opt f base = match opt with None -> base | Some v -> f v base
337
+
338
+
let to_wire (t : t) : Wire.t =
339
+
Wire.empty
340
+
|> Wire.with_allowed_tools t.allowed_tools
341
+
|> Wire.with_disallowed_tools t.disallowed_tools
342
+
|> Wire.with_max_thinking_tokens t.max_thinking_tokens
343
+
|> apply_opt t.system_prompt Wire.with_system_prompt
344
+
|> apply_opt t.append_system_prompt Wire.with_append_system_prompt
345
+
|> apply_opt t.permission_mode Wire.with_permission_mode
346
+
|> apply_opt t.model Wire.with_model
347
+
|> Wire.with_continue_conversation t.continue_conversation
348
+
|> apply_opt t.resume Wire.with_resume
349
+
|> apply_opt t.max_turns Wire.with_max_turns
350
+
|> apply_opt t.permission_prompt_tool_name
351
+
Wire.with_permission_prompt_tool_name
352
+
|> apply_opt t.settings Wire.with_settings
353
+
|> Wire.with_add_dirs t.add_dirs
354
+
|> apply_opt t.max_budget_usd Wire.with_max_budget_usd
355
+
|> apply_opt t.fallback_model Wire.with_fallback_model
356
+
|> apply_opt t.setting_sources Wire.with_setting_sources
357
+
|> apply_opt t.max_buffer_size Wire.with_max_buffer_size
358
+
|> apply_opt t.user Wire.with_user
359
+
|> apply_opt t.output_format Wire.with_output_format
360
+
end
361
+
362
+
let pp ppf t = Jsont.pp_value Wire.jsont () ppf (Advanced.to_wire t)
+344
lib/options.mli
+344
lib/options.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Configuration options for Claude sessions.
7
+
8
+
This module provides comprehensive configuration options for controlling
9
+
Claude's behavior, including tool permissions, system prompts, models,
10
+
execution environment, cost controls, and structured outputs.
11
+
12
+
{2 Overview}
13
+
14
+
Options control all aspects of Claude's behavior:
15
+
- {b Permissions}: Which tools Claude can use and how permission is granted
16
+
- {b Models}: Which AI model to use and fallback options
17
+
- {b Environment}: Working directory, environment variables, settings
18
+
- {b Cost Control}: Budget limits to prevent runaway spending
19
+
- {b Hooks}: Intercept and modify tool execution
20
+
- {b Structured Output}: JSON schema validation for responses
21
+
- {b Session Management}: Continue or resume conversations
22
+
23
+
{2 Builder Pattern}
24
+
25
+
Options use a functional builder pattern - each [with_*] function returns a
26
+
new options value with the specified field updated:
27
+
28
+
{[
29
+
let options =
30
+
Options.default
31
+
|> Options.with_model `Sonnet_4_5
32
+
|> Options.with_max_budget_usd 1.0
33
+
|> Options.with_permission_mode Permissions.Mode.Accept_edits
34
+
]}
35
+
36
+
{2 Common Configuration Scenarios}
37
+
38
+
{3 CI/CD: Isolated, Reproducible Builds}
39
+
40
+
{[
41
+
let ci_config =
42
+
Options.default |> Options.with_no_settings (* Ignore user config *)
43
+
|> Options.with_max_budget_usd 0.50 (* 50 cent limit *)
44
+
|> Options.with_permission_mode Permissions.Mode.Bypass_permissions
45
+
|> Options.with_model `Haiku_4
46
+
]}
47
+
48
+
{3 Production: Cost Control with Fallback}
49
+
50
+
{[
51
+
let prod_config =
52
+
Options.default
53
+
|> Options.with_model `Sonnet_4_5
54
+
|> Options.with_fallback_model `Haiku_4
55
+
|> Options.with_max_budget_usd 10.0 (* $10 daily limit *)
56
+
|> Options.with_max_buffer_size 5_000_000
57
+
]}
58
+
59
+
{3 Development: User Settings with Overrides}
60
+
61
+
{[
62
+
let dev_config =
63
+
Options.default
64
+
|> Options.with_max_budget_usd 1.0
65
+
|> Options.with_permission_mode Permissions.Mode.Default
66
+
]}
67
+
68
+
{2 Advanced Options}
69
+
70
+
{3 Budget Control}
71
+
72
+
Use {!with_max_budget_usd} to set hard spending limits. Claude will
73
+
terminate the session if the budget is exceeded, preventing runaway costs.
74
+
75
+
{3 Settings Isolation}
76
+
77
+
Use {!with_no_settings} to control which configuration files are loaded.
78
+
This is critical for reproducible builds in CI/CD environments.
79
+
80
+
{3 Model Fallback}
81
+
82
+
Use {!with_fallback_model} to specify an alternative model when the primary
83
+
model is unavailable or overloaded. This improves reliability. *)
84
+
85
+
val src : Logs.Src.t
86
+
(** The log source for options operations. *)
87
+
88
+
(** {1 Wire Format} *)
89
+
90
+
(** Wire-format encoding for options serialised in JSON config files.
91
+
92
+
Field names use camelCase. Unknown fields are preserved for forward
93
+
compatibility. *)
94
+
module Wire : sig
95
+
type setting_source = User | Project | Local
96
+
97
+
val setting_source_jsont : setting_source Jsont.t
98
+
99
+
type t
100
+
101
+
val empty : t
102
+
val pp : Format.formatter -> t -> unit
103
+
val jsont : t Jsont.t
104
+
val allowed_tools : t -> string list
105
+
val disallowed_tools : t -> string list
106
+
val max_thinking_tokens : t -> int option
107
+
val system_prompt : t -> string option
108
+
val append_system_prompt : t -> string option
109
+
val permission_mode : t -> Permissions.Mode.t option
110
+
val model : t -> Model.t option
111
+
val continue_conversation : t -> bool
112
+
val resume : t -> string option
113
+
val max_turns : t -> int option
114
+
val permission_prompt_tool_name : t -> string option
115
+
val settings : t -> string option
116
+
val add_dirs : t -> string list
117
+
val max_budget_usd : t -> float option
118
+
val fallback_model : t -> Model.t option
119
+
val setting_sources : t -> setting_source list option
120
+
val max_buffer_size : t -> int option
121
+
val user : t -> string option
122
+
val output_format : t -> Structured_output.t option
123
+
val unknown : t -> Unknown.t
124
+
val with_allowed_tools : string list -> t -> t
125
+
val with_disallowed_tools : string list -> t -> t
126
+
val with_max_thinking_tokens : int -> t -> t
127
+
val with_system_prompt : string -> t -> t
128
+
val with_append_system_prompt : string -> t -> t
129
+
val with_permission_mode : Permissions.Mode.t -> t -> t
130
+
val with_model : Model.t -> t -> t
131
+
val with_continue_conversation : bool -> t -> t
132
+
val with_resume : string -> t -> t
133
+
val with_max_turns : int -> t -> t
134
+
val with_permission_prompt_tool_name : string -> t -> t
135
+
val with_settings : string -> t -> t
136
+
val with_add_dirs : string list -> t -> t
137
+
val with_max_budget_usd : float -> t -> t
138
+
val with_fallback_model : Model.t -> t -> t
139
+
val with_setting_sources : setting_source list -> t -> t
140
+
val with_max_buffer_size : int -> t -> t
141
+
val with_user : string -> t -> t
142
+
val with_output_format : Structured_output.t -> t -> t
143
+
end
144
+
145
+
(** {1 Types} *)
146
+
147
+
type t
148
+
(** The type of configuration options. *)
149
+
150
+
val pp : Format.formatter -> t -> unit
151
+
(** [pp ppf t] pretty-prints the options configuration. *)
152
+
153
+
val default : t
154
+
(** [default] returns the default configuration with sensible defaults:
155
+
- No tool restrictions
156
+
- 8000 max thinking tokens
157
+
- Default allow permission callback
158
+
- No custom prompts or model override. *)
159
+
160
+
(** {1 Builder Pattern} *)
161
+
162
+
val with_allowed_tools : string list -> t -> t
163
+
(** [with_allowed_tools tools t] sets the allowed tools. *)
164
+
165
+
val with_disallowed_tools : string list -> t -> t
166
+
(** [with_disallowed_tools tools t] sets the disallowed tools. *)
167
+
168
+
val with_max_thinking_tokens : int -> t -> t
169
+
(** [with_max_thinking_tokens tokens t] sets the maximum thinking tokens. *)
170
+
171
+
val with_system_prompt : string -> t -> t
172
+
(** [with_system_prompt prompt t] sets the system prompt override. *)
173
+
174
+
val with_append_system_prompt : string -> t -> t
175
+
(** [with_append_system_prompt prompt t] sets the system prompt append. *)
176
+
177
+
val with_permission_mode : Permissions.Mode.t -> t -> t
178
+
(** [with_permission_mode mode t] sets the permission mode. *)
179
+
180
+
val with_permission_callback : Permissions.callback -> t -> t
181
+
(** [with_permission_callback callback t] sets the permission callback. *)
182
+
183
+
val with_model : Model.t -> t -> t
184
+
(** [with_model model t] sets the model override using a typed Model.t. *)
185
+
186
+
val with_cwd : [> Eio.Fs.dir_ty ] Eio.Path.t -> t -> t
187
+
(** [with_cwd cwd t] sets the working directory. *)
188
+
189
+
val with_env : (string * string) list -> t -> t
190
+
(** [with_env env t] sets the environment variables. *)
191
+
192
+
val with_continue_conversation : bool -> t -> t
193
+
(** [with_continue_conversation continue t] sets whether to continue
194
+
conversation. *)
195
+
196
+
val with_resume : string -> t -> t
197
+
(** [with_resume session_id t] sets the session ID to resume. *)
198
+
199
+
val with_max_turns : int -> t -> t
200
+
(** [with_max_turns turns t] sets the maximum number of turns. *)
201
+
202
+
val with_permission_prompt_tool_name : string -> t -> t
203
+
(** [with_permission_prompt_tool_name tool t] sets the permission prompt tool
204
+
name. *)
205
+
206
+
val with_settings : string -> t -> t
207
+
(** [with_settings path t] sets the path to settings file. *)
208
+
209
+
val with_add_dirs : string list -> t -> t
210
+
(** [with_add_dirs dirs t] sets the additional allowed directories. *)
211
+
212
+
val with_debug_stderr : [> Eio.Flow.sink_ty ] Eio.Flow.sink -> t -> t
213
+
(** [with_debug_stderr sink t] sets the debug output sink. *)
214
+
215
+
val with_hooks : Hooks.t -> t -> t
216
+
(** [with_hooks hooks t] sets the hooks configuration. *)
217
+
218
+
val with_max_budget_usd : float -> t -> t
219
+
(** [with_max_budget_usd budget t] sets the maximum spending limit in USD. The
220
+
session will terminate if this limit is exceeded. *)
221
+
222
+
val with_fallback_model : Model.t -> t -> t
223
+
(** [with_fallback_model model t] sets the fallback model using a typed Model.t.
224
+
*)
225
+
226
+
val with_no_settings : t -> t
227
+
(** [with_no_settings t] disables all settings loading (user, project, local).
228
+
Useful for CI/CD environments where you want isolated, reproducible
229
+
behavior. *)
230
+
231
+
val with_max_buffer_size : int -> t -> t
232
+
(** [with_max_buffer_size size t] sets the maximum stdout buffer size in bytes.
233
+
*)
234
+
235
+
val with_user : string -> t -> t
236
+
(** [with_user user t] sets the Unix user for subprocess execution. *)
237
+
238
+
val with_output_format : Structured_output.t -> t -> t
239
+
(** [with_output_format format t] sets the structured output format. *)
240
+
241
+
val with_extra_args : (string * string option) list -> t -> t
242
+
(** [with_extra_args args t] sets the additional CLI flags. *)
243
+
244
+
val with_mcp_server : name:string -> Mcp_server.t -> t -> t
245
+
(** [with_mcp_server ~name server t] adds an in-process MCP server.
246
+
247
+
Multiple servers can be added. Tools from server "foo" are accessed as
248
+
[mcp__foo__<tool_name>]. *)
249
+
250
+
(** {1 Accessors} *)
251
+
252
+
val allowed_tools : t -> string list
253
+
(** [allowed_tools t] returns the list of allowed tools. *)
254
+
255
+
val disallowed_tools : t -> string list
256
+
(** [disallowed_tools t] returns the list of disallowed tools. *)
257
+
258
+
val max_thinking_tokens : t -> int
259
+
(** [max_thinking_tokens t] returns the maximum thinking tokens. *)
260
+
261
+
val system_prompt : t -> string option
262
+
(** [system_prompt t] returns the optional system prompt override. *)
263
+
264
+
val append_system_prompt : t -> string option
265
+
(** [append_system_prompt t] returns the optional system prompt append. *)
266
+
267
+
val permission_mode : t -> Permissions.Mode.t option
268
+
(** [permission_mode t] returns the optional permission mode. *)
269
+
270
+
val permission_callback : t -> Permissions.callback option
271
+
(** [permission_callback t] returns the optional permission callback. *)
272
+
273
+
val model : t -> Model.t option
274
+
(** [model t] returns the optional model override. *)
275
+
276
+
val cwd : t -> Eio.Fs.dir_ty Eio.Path.t option
277
+
(** [cwd t] returns the optional working directory. *)
278
+
279
+
val env : t -> (string * string) list
280
+
(** [env t] returns the environment variables. *)
281
+
282
+
val continue_conversation : t -> bool
283
+
(** [continue_conversation t] returns whether to continue an existing
284
+
conversation. *)
285
+
286
+
val resume : t -> string option
287
+
(** [resume t] returns the optional session ID to resume. *)
288
+
289
+
val max_turns : t -> int option
290
+
(** [max_turns t] returns the optional maximum number of turns. *)
291
+
292
+
val permission_prompt_tool_name : t -> string option
293
+
(** [permission_prompt_tool_name t] returns the optional tool name for
294
+
permission prompts. *)
295
+
296
+
val settings : t -> string option
297
+
(** [settings t] returns the optional path to settings file. *)
298
+
299
+
val add_dirs : t -> string list
300
+
(** [add_dirs t] returns the list of additional allowed directories. *)
301
+
302
+
val debug_stderr : t -> Eio.Flow.sink_ty Eio.Flow.sink option
303
+
(** [debug_stderr t] returns the optional debug output sink. *)
304
+
305
+
val hooks : t -> Hooks.t option
306
+
(** [hooks t] returns the optional hooks configuration. *)
307
+
308
+
val max_budget_usd : t -> float option
309
+
(** [max_budget_usd t] returns the optional spending limit in USD. *)
310
+
311
+
val fallback_model : t -> Model.t option
312
+
(** [fallback_model t] returns the optional fallback model. *)
313
+
314
+
val setting_sources : t -> Wire.setting_source list option
315
+
(** [setting_sources t] returns the optional list of setting sources to load. *)
316
+
317
+
val max_buffer_size : t -> int option
318
+
(** [max_buffer_size t] returns the optional stdout buffer size in bytes. *)
319
+
320
+
val user : t -> string option
321
+
(** [user t] returns the optional Unix user for subprocess execution. *)
322
+
323
+
val output_format : t -> Structured_output.t option
324
+
(** [output_format t] returns the optional structured output format. *)
325
+
326
+
val extra_args : t -> (string * string option) list
327
+
(** [extra_args t] returns the additional CLI flags. *)
328
+
329
+
val mcp_servers : t -> (string * Mcp_server.t) list
330
+
(** [mcp_servers t] returns the list of in-process MCP servers. *)
331
+
332
+
(** {1 Logging} *)
333
+
334
+
val log_options : t -> unit
335
+
(** [log_options t] logs the current options configuration. *)
336
+
337
+
(** {1 Advanced: Wire Format Conversion} *)
338
+
339
+
module Advanced : sig
340
+
val to_wire : t -> Wire.t
341
+
(** [to_wire t] converts to wire format (excludes Eio types and callbacks).
342
+
This is used internally by the client to send options to the Claude CLI.
343
+
*)
344
+
end
+72
lib/outgoing.ml
+72
lib/outgoing.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
+
| Message of Message.t
8
+
| Control_request of Control.control_request
9
+
| Control_response of Control.control_response
10
+
11
+
let jsont : t Jsont.t =
12
+
let case_control_request =
13
+
Jsont.Object.Case.map "control_request" Control.control_request_jsont
14
+
~dec:(fun v -> Control_request v)
15
+
in
16
+
let case_control_response =
17
+
Jsont.Object.Case.map "control_response" Control.control_response_jsont
18
+
~dec:(fun v -> Control_response v)
19
+
in
20
+
let case_user =
21
+
Jsont.Object.Case.map "user" Message.User.outgoing_jsont ~dec:(fun v ->
22
+
Message (Message.User v))
23
+
in
24
+
let case_assistant =
25
+
Jsont.Object.Case.map "assistant" Message.Assistant.jsont ~dec:(fun v ->
26
+
Message (Message.Assistant v))
27
+
in
28
+
let case_system =
29
+
Jsont.Object.Case.map "system" Message.System.jsont ~dec:(fun v ->
30
+
Message (Message.System v))
31
+
in
32
+
let case_result =
33
+
Jsont.Object.Case.map "result" Message.Result.jsont ~dec:(fun v ->
34
+
Message (Message.Result v))
35
+
in
36
+
let enc_case = function
37
+
| Control_request v -> Jsont.Object.Case.value case_control_request v
38
+
| Control_response v -> Jsont.Object.Case.value case_control_response v
39
+
| Message msg -> (
40
+
match msg with
41
+
| Message.User u -> Jsont.Object.Case.value case_user u
42
+
| Message.Assistant a -> Jsont.Object.Case.value case_assistant a
43
+
| Message.System s -> Jsont.Object.Case.value case_system s
44
+
| Message.Result r -> Jsont.Object.Case.value case_result r)
45
+
in
46
+
let cases =
47
+
Jsont.Object.Case.
48
+
[
49
+
make case_control_request;
50
+
make case_control_response;
51
+
make case_user;
52
+
make case_assistant;
53
+
make case_system;
54
+
make case_result;
55
+
]
56
+
in
57
+
Jsont.Object.map ~kind:"Outgoing" Fun.id
58
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
59
+
~tag_to_string:Fun.id ~tag_compare:String.compare
60
+
|> Jsont.Object.finish
61
+
62
+
let pp ppf t = Jsont.pp_value jsont () ppf t
63
+
64
+
let to_json t =
65
+
match Jsont.Json.encode jsont t with
66
+
| Ok json -> json
67
+
| Error e -> invalid_arg ("to_json: " ^ e)
68
+
69
+
let of_json json =
70
+
match Jsont.Json.decode jsont json with
71
+
| Ok v -> v
72
+
| Error e -> invalid_arg ("of_json: " ^ e)
+24
lib/outgoing.mli
+24
lib/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
+
type t =
9
+
| Message of Message.t
10
+
| Control_request of Control.control_request
11
+
| Control_response of Control.control_response
12
+
13
+
val jsont : t Jsont.t
14
+
(** Codec for outgoing messages. *)
15
+
16
+
val pp : Format.formatter -> t -> unit
17
+
(** [pp ppf t] pretty-prints the outgoing message. *)
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. *)
+298
lib/permissions.ml
+298
lib/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 = Logs.Src.create "claude.permission" ~doc:"Claude permission system"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
module Mode = struct
11
+
type t = Default | Accept_edits | Plan | Bypass_permissions
12
+
13
+
let to_string = function
14
+
| Default -> "default"
15
+
| Accept_edits -> "acceptEdits"
16
+
| Plan -> "plan"
17
+
| Bypass_permissions -> "bypassPermissions"
18
+
19
+
let of_string = function
20
+
| "default" -> Default
21
+
| "acceptEdits" -> Accept_edits
22
+
| "plan" -> Plan
23
+
| "bypassPermissions" -> Bypass_permissions
24
+
| s ->
25
+
raise (Invalid_argument (Fmt.str "Mode.of_string: unknown mode %s" s))
26
+
27
+
let jsont : t Jsont.t =
28
+
Jsont.enum
29
+
[
30
+
("default", Default);
31
+
("acceptEdits", Accept_edits);
32
+
("plan", Plan);
33
+
("bypassPermissions", Bypass_permissions);
34
+
]
35
+
end
36
+
37
+
module Behavior = struct
38
+
type t = Allow | Deny | Ask
39
+
40
+
let to_string = function Allow -> "allow" | Deny -> "deny" | Ask -> "ask"
41
+
42
+
let of_string = function
43
+
| "allow" -> Allow
44
+
| "deny" -> Deny
45
+
| "ask" -> Ask
46
+
| s ->
47
+
raise
48
+
(Invalid_argument
49
+
(Fmt.str "Behavior.of_string: unknown behavior %s" s))
50
+
51
+
let jsont : t Jsont.t =
52
+
Jsont.enum [ ("allow", Allow); ("deny", Deny); ("ask", Ask) ]
53
+
end
54
+
55
+
module Rule = struct
56
+
type t = {
57
+
tool_name : string;
58
+
rule_content : string option;
59
+
unknown : Unknown.t;
60
+
}
61
+
62
+
let create ~tool_name ?rule_content ?(unknown = Unknown.empty) () =
63
+
{ tool_name; rule_content; unknown }
64
+
65
+
let tool_name t = t.tool_name
66
+
let rule_content t = t.rule_content
67
+
let unknown t = t.unknown
68
+
69
+
let jsont : t Jsont.t =
70
+
let make tool_name rule_content unknown =
71
+
{ tool_name; rule_content; unknown }
72
+
in
73
+
Jsont.Object.map ~kind:"Rule" make
74
+
|> Jsont.Object.mem "toolName" Jsont.string ~enc:tool_name
75
+
|> Jsont.Object.opt_mem "ruleContent" Jsont.string ~enc:rule_content
76
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
77
+
|> Jsont.Object.finish
78
+
end
79
+
80
+
module Update = struct
81
+
type destination =
82
+
| User_settings
83
+
| Project_settings
84
+
| Local_settings
85
+
| Session
86
+
87
+
let destination_jsont : destination Jsont.t =
88
+
Jsont.enum
89
+
[
90
+
("userSettings", User_settings);
91
+
("projectSettings", Project_settings);
92
+
("localSettings", Local_settings);
93
+
("session", Session);
94
+
]
95
+
96
+
type update_type =
97
+
| Add_rules
98
+
| Replace_rules
99
+
| Remove_rules
100
+
| Set_mode
101
+
| Add_directories
102
+
| Remove_directories
103
+
104
+
let update_type_jsont : update_type Jsont.t =
105
+
Jsont.enum
106
+
[
107
+
("addRules", Add_rules);
108
+
("replaceRules", Replace_rules);
109
+
("removeRules", Remove_rules);
110
+
("setMode", Set_mode);
111
+
("addDirectories", Add_directories);
112
+
("removeDirectories", Remove_directories);
113
+
]
114
+
115
+
type t = {
116
+
update_type : update_type;
117
+
rules : Rule.t list option;
118
+
behavior : Behavior.t option;
119
+
mode : Mode.t option;
120
+
directories : string list option;
121
+
destination : destination option;
122
+
unknown : Unknown.t;
123
+
}
124
+
125
+
let create ~update_type ?rules ?behavior ?mode ?directories ?destination
126
+
?(unknown = Unknown.empty) () =
127
+
{ update_type; rules; behavior; mode; directories; destination; unknown }
128
+
129
+
let update_type t = t.update_type
130
+
let rules t = t.rules
131
+
let behavior t = t.behavior
132
+
let mode t = t.mode
133
+
let directories t = t.directories
134
+
let destination t = t.destination
135
+
let unknown t = t.unknown
136
+
137
+
let jsont : t Jsont.t =
138
+
let make update_type rules behavior mode directories destination unknown =
139
+
{ update_type; rules; behavior; mode; directories; destination; unknown }
140
+
in
141
+
Jsont.Object.map ~kind:"Update" make
142
+
|> Jsont.Object.mem "type" update_type_jsont ~enc:update_type
143
+
|> Jsont.Object.opt_mem "rules" (Jsont.list Rule.jsont) ~enc:rules
144
+
|> Jsont.Object.opt_mem "behavior" Behavior.jsont ~enc:behavior
145
+
|> Jsont.Object.opt_mem "mode" Mode.jsont ~enc:mode
146
+
|> Jsont.Object.opt_mem "directories" (Jsont.list Jsont.string)
147
+
~enc:directories
148
+
|> Jsont.Object.opt_mem "destination" destination_jsont ~enc:destination
149
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
150
+
|> Jsont.Object.finish
151
+
end
152
+
153
+
module Context = struct
154
+
type t = { suggestions : Update.t list; unknown : Unknown.t }
155
+
156
+
let create ?(suggestions = []) ?(unknown = Unknown.empty) () =
157
+
{ suggestions; unknown }
158
+
159
+
let suggestions t = t.suggestions
160
+
let unknown t = t.unknown
161
+
162
+
let jsont : t Jsont.t =
163
+
let make suggestions unknown = { suggestions; unknown } in
164
+
Jsont.Object.map ~kind:"Context" make
165
+
|> Jsont.Object.mem "suggestions" (Jsont.list Update.jsont) ~enc:suggestions
166
+
~dec_absent:[]
167
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:unknown
168
+
|> Jsont.Object.finish
169
+
end
170
+
171
+
module Result = struct
172
+
type t =
173
+
| Allow of {
174
+
updated_input : Jsont.json option;
175
+
updated_permissions : Update.t list option;
176
+
unknown : Unknown.t;
177
+
}
178
+
| Deny of { message : string; interrupt : bool; unknown : Unknown.t }
179
+
180
+
let allow ?updated_input ?updated_permissions ?(unknown = Unknown.empty) () =
181
+
Allow { updated_input; updated_permissions; unknown }
182
+
183
+
let deny ~message ~interrupt ?(unknown = Unknown.empty) () =
184
+
Deny { message; interrupt; unknown }
185
+
186
+
let jsont : t Jsont.t =
187
+
let allow_record =
188
+
let make updated_input updated_permissions unknown =
189
+
Allow { updated_input; updated_permissions; unknown }
190
+
in
191
+
Jsont.Object.map ~kind:"AllowRecord" make
192
+
|> Jsont.Object.mem "updatedInput" (Jsont.option Jsont.json)
193
+
~enc:(function
194
+
| Allow { updated_input; _ } -> updated_input | _ -> None)
195
+
~dec_absent:None
196
+
|> Jsont.Object.opt_mem "updatedPermissions" (Jsont.list Update.jsont)
197
+
~enc:(function
198
+
| Allow { updated_permissions; _ } -> updated_permissions
199
+
| _ -> None)
200
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(function
201
+
| Allow { unknown; _ } -> unknown
202
+
| _ -> Unknown.empty)
203
+
|> Jsont.Object.finish
204
+
in
205
+
let deny_record =
206
+
let make message interrupt unknown =
207
+
Deny { message; interrupt; unknown }
208
+
in
209
+
Jsont.Object.map ~kind:"DenyRecord" make
210
+
|> Jsont.Object.mem "message" Jsont.string ~enc:(function
211
+
| Deny { message; _ } -> message
212
+
| _ -> "")
213
+
|> Jsont.Object.mem "interrupt" Jsont.bool ~enc:(function
214
+
| Deny { interrupt; _ } -> interrupt
215
+
| _ -> false)
216
+
|> Jsont.Object.keep_unknown Unknown.mems ~enc:(function
217
+
| Deny { unknown; _ } -> unknown
218
+
| _ -> Unknown.empty)
219
+
|> Jsont.Object.finish
220
+
in
221
+
let case_allow =
222
+
Jsont.Object.Case.map "allow" allow_record ~dec:(fun v -> v)
223
+
in
224
+
let case_deny =
225
+
Jsont.Object.Case.map "deny" deny_record ~dec:(fun v -> v)
226
+
in
227
+
let enc_case = function
228
+
| Allow _ as v -> Jsont.Object.Case.value case_allow v
229
+
| Deny _ as v -> Jsont.Object.Case.value case_deny v
230
+
in
231
+
let cases = Jsont.Object.Case.[ make case_allow; make case_deny ] in
232
+
Jsont.Object.map ~kind:"Result" Fun.id
233
+
|> Jsont.Object.case_mem "behavior" 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 Decision = struct
239
+
type t =
240
+
| Allow of { updated_input : Tool_input.t option }
241
+
| Deny of { message : string; interrupt : bool }
242
+
243
+
let allow ?updated_input () = Allow { updated_input }
244
+
let deny ~message ~interrupt = Deny { message; interrupt }
245
+
let is_allow = function Allow _ -> true | Deny _ -> false
246
+
let is_deny = function Allow _ -> false | Deny _ -> true
247
+
248
+
let updated_input = function
249
+
| Allow { updated_input } -> updated_input
250
+
| Deny _ -> None
251
+
252
+
let deny_message = function
253
+
| Allow _ -> None
254
+
| Deny { message; _ } -> Some message
255
+
256
+
let deny_interrupt = function
257
+
| Allow _ -> false
258
+
| Deny { interrupt; _ } -> interrupt
259
+
260
+
let to_proto_result ~original_input (t : t) : Result.t =
261
+
match t with
262
+
| Allow { updated_input } ->
263
+
let updated_input_json =
264
+
match updated_input with
265
+
| Some input -> Some (Tool_input.to_json input)
266
+
| None -> Some (Tool_input.to_json original_input)
267
+
in
268
+
Result.allow ?updated_input:updated_input_json ()
269
+
| Deny { message; interrupt } -> Result.deny ~message ~interrupt ()
270
+
end
271
+
272
+
type context = {
273
+
tool_name : string;
274
+
input : Tool_input.t;
275
+
suggested_rules : Rule.t list;
276
+
}
277
+
278
+
let extract_rules_from_proto_updates updates =
279
+
List.concat_map
280
+
(fun update ->
281
+
match Update.rules update with Some rules -> rules | None -> [])
282
+
updates
283
+
284
+
type callback = context -> Decision.t
285
+
286
+
let default_allow _ctx = Decision.allow ()
287
+
288
+
let discovery log ctx =
289
+
List.iter (fun rule -> log := rule :: !log) ctx.suggested_rules;
290
+
Decision.allow ()
291
+
292
+
let log_permission_check ~tool_name ~decision =
293
+
match decision with
294
+
| Decision.Allow _ ->
295
+
Log.info (fun m -> m "Permission granted for tool: %s" tool_name)
296
+
| Decision.Deny { message; _ } ->
297
+
Log.warn (fun m ->
298
+
m "Permission denied for tool %s: %s" tool_name message)
+155
lib/permissions.mli
+155
lib/permissions.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Permission control for tool usage. *)
7
+
8
+
val src : Logs.Src.t
9
+
10
+
(** {1 Permission Modes} *)
11
+
12
+
module Mode : sig
13
+
type t = Default | Accept_edits | Plan | Bypass_permissions
14
+
15
+
val to_string : t -> string
16
+
val of_string : string -> t
17
+
val jsont : t Jsont.t
18
+
end
19
+
20
+
(** {1 Behaviors} *)
21
+
22
+
module Behavior : sig
23
+
type t = Allow | Deny | Ask
24
+
25
+
val to_string : t -> string
26
+
val of_string : string -> t
27
+
val jsont : t Jsont.t
28
+
end
29
+
30
+
(** {1 Permission Rules} *)
31
+
32
+
module Rule : sig
33
+
type t
34
+
35
+
val create :
36
+
tool_name:string -> ?rule_content:string -> ?unknown:Unknown.t -> unit -> t
37
+
38
+
val tool_name : t -> string
39
+
val rule_content : t -> string option
40
+
val unknown : t -> Unknown.t
41
+
val jsont : t Jsont.t
42
+
end
43
+
44
+
(** {1 Permission Updates} *)
45
+
46
+
module Update : sig
47
+
type destination =
48
+
| User_settings
49
+
| Project_settings
50
+
| Local_settings
51
+
| Session
52
+
53
+
val destination_jsont : destination Jsont.t
54
+
55
+
type update_type =
56
+
| Add_rules
57
+
| Replace_rules
58
+
| Remove_rules
59
+
| Set_mode
60
+
| Add_directories
61
+
| Remove_directories
62
+
63
+
val update_type_jsont : update_type Jsont.t
64
+
65
+
type t
66
+
67
+
val create :
68
+
update_type:update_type ->
69
+
?rules:Rule.t list ->
70
+
?behavior:Behavior.t ->
71
+
?mode:Mode.t ->
72
+
?directories:string list ->
73
+
?destination:destination ->
74
+
?unknown:Unknown.t ->
75
+
unit ->
76
+
t
77
+
78
+
val update_type : t -> update_type
79
+
val rules : t -> Rule.t list option
80
+
val behavior : t -> Behavior.t option
81
+
val mode : t -> Mode.t option
82
+
val directories : t -> string list option
83
+
val destination : t -> destination option
84
+
val unknown : t -> Unknown.t
85
+
val jsont : t Jsont.t
86
+
end
87
+
88
+
(** {1 Wire-level Permission Context} *)
89
+
90
+
module Context : sig
91
+
type t
92
+
93
+
val create : ?suggestions:Update.t list -> ?unknown:Unknown.t -> unit -> t
94
+
val suggestions : t -> Update.t list
95
+
val unknown : t -> Unknown.t
96
+
val jsont : t Jsont.t
97
+
end
98
+
99
+
(** {1 Wire-level Permission Result} *)
100
+
101
+
module Result : sig
102
+
type t =
103
+
| Allow of {
104
+
updated_input : Jsont.json option;
105
+
updated_permissions : Update.t list option;
106
+
unknown : Unknown.t;
107
+
}
108
+
| Deny of { message : string; interrupt : bool; unknown : Unknown.t }
109
+
110
+
val allow :
111
+
?updated_input:Jsont.json ->
112
+
?updated_permissions:Update.t list ->
113
+
?unknown:Unknown.t ->
114
+
unit ->
115
+
t
116
+
117
+
val deny : message:string -> interrupt:bool -> ?unknown:Unknown.t -> unit -> t
118
+
val jsont : t Jsont.t
119
+
end
120
+
121
+
(** {1 Permission Decisions (typed)} *)
122
+
123
+
module Decision : sig
124
+
type t
125
+
126
+
val allow : ?updated_input:Tool_input.t -> unit -> t
127
+
val deny : message:string -> interrupt:bool -> t
128
+
val is_allow : t -> bool
129
+
val is_deny : t -> bool
130
+
val updated_input : t -> Tool_input.t option
131
+
val deny_message : t -> string option
132
+
val deny_interrupt : t -> bool
133
+
val to_proto_result : original_input:Tool_input.t -> t -> Result.t
134
+
end
135
+
136
+
(** {1 Permission Context (typed)} *)
137
+
138
+
type context = {
139
+
tool_name : string;
140
+
input : Tool_input.t;
141
+
suggested_rules : Rule.t list;
142
+
}
143
+
144
+
val extract_rules_from_proto_updates : Update.t list -> Rule.t list
145
+
146
+
(** {1 Permission Callbacks} *)
147
+
148
+
type callback = context -> Decision.t
149
+
150
+
val default_allow : callback
151
+
val discovery : Rule.t list ref -> callback
152
+
153
+
(** {1 Logging} *)
154
+
155
+
val log_permission_check : tool_name:string -> decision:Decision.t -> unit
+126
lib/response.ml
+126
lib/response.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 = Content_block.Text.t
8
+
9
+
let content = Content_block.Text.text
10
+
let of_block block = block
11
+
end
12
+
13
+
module Tool_use = struct
14
+
type t = Content_block.Tool_use.t
15
+
16
+
let id = Content_block.Tool_use.id
17
+
let name = Content_block.Tool_use.name
18
+
let input = Content_block.Tool_use.input
19
+
let of_block block = block
20
+
end
21
+
22
+
module Thinking = struct
23
+
type t = Content_block.Thinking.t
24
+
25
+
let content = Content_block.Thinking.thinking
26
+
let signature = Content_block.Thinking.signature
27
+
let of_block block = block
28
+
end
29
+
30
+
module Init = struct
31
+
type t = Message.System.t
32
+
33
+
let session_id = Message.System.session_id
34
+
let model = Message.System.model
35
+
let cwd = Message.System.cwd
36
+
let of_system sys = if Message.System.is_init sys then Some sys else None
37
+
end
38
+
39
+
module Error = struct
40
+
type t =
41
+
| System_error of Message.System.t
42
+
| Assistant_error of Message.Assistant.t * Message.Assistant.error
43
+
44
+
let message = function
45
+
| System_error sys ->
46
+
Option.value (Message.System.error_message sys) ~default:"Unknown error"
47
+
| Assistant_error (_, err) -> (
48
+
match err with
49
+
| `Authentication_failed -> "Authentication failed"
50
+
| `Billing_error -> "Billing error"
51
+
| `Rate_limit -> "Rate limit exceeded"
52
+
| `Invalid_request -> "Invalid request"
53
+
| `Server_error -> "Server error"
54
+
| `Unknown -> "Unknown error")
55
+
56
+
let is_system_error = function System_error _ -> true | _ -> false
57
+
let is_assistant_error = function Assistant_error _ -> true | _ -> false
58
+
59
+
let of_system sys =
60
+
if Message.System.is_error sys then Some (System_error sys) else None
61
+
62
+
let of_assistant msg =
63
+
match Message.Assistant.error msg with
64
+
| Some err -> Some (Assistant_error (msg, err))
65
+
| None -> None
66
+
end
67
+
68
+
module Complete = struct
69
+
type t = Message.Result.t
70
+
71
+
let duration_ms = Message.Result.duration_ms
72
+
let num_turns = Message.Result.num_turns
73
+
let session_id = Message.Result.session_id
74
+
let total_cost_usd = Message.Result.total_cost_usd
75
+
let usage = Message.Result.usage
76
+
let result_text = Message.Result.result_text
77
+
let structured_output = Message.Result.structured_output
78
+
let of_result result = result
79
+
end
80
+
81
+
type t =
82
+
| Text of Text.t
83
+
| Tool_use of Tool_use.t
84
+
| Tool_result of Content_block.Tool_result.t
85
+
| Thinking of Thinking.t
86
+
| Init of Init.t
87
+
| Error of Error.t
88
+
| Complete of Complete.t
89
+
90
+
let pp ppf = function
91
+
| Text _ -> Format.pp_print_string ppf "Text"
92
+
| Tool_use _ -> Format.pp_print_string ppf "Tool_use"
93
+
| Tool_result _ -> Format.pp_print_string ppf "Tool_result"
94
+
| Thinking _ -> Format.pp_print_string ppf "Thinking"
95
+
| Init _ -> Format.pp_print_string ppf "Init"
96
+
| Error _ -> Format.pp_print_string ppf "Error"
97
+
| Complete _ -> Format.pp_print_string ppf "Complete"
98
+
99
+
let of_message = function
100
+
| Message.User _ ->
101
+
(* User messages are inputs, not responses *)
102
+
[]
103
+
| Message.Assistant msg -> (
104
+
(* Check for assistant error first *)
105
+
match Error.of_assistant msg with
106
+
| Some err -> [ Error err ]
107
+
| None ->
108
+
(* Convert content blocks to response events *)
109
+
Message.Assistant.content msg
110
+
|> List.map (function
111
+
| Content_block.Text text -> Text (Text.of_block text)
112
+
| Content_block.Tool_use tool -> Tool_use (Tool_use.of_block tool)
113
+
| Content_block.Tool_result result -> Tool_result result
114
+
| Content_block.Thinking thinking ->
115
+
Thinking (Thinking.of_block thinking)))
116
+
| Message.System sys -> (
117
+
(* System messages can be Init or Error *)
118
+
match Init.of_system sys with
119
+
| Some init -> [ Init init ]
120
+
| None -> (
121
+
match Error.of_system sys with
122
+
| Some err -> [ Error err ]
123
+
| None -> []))
124
+
| Message.Result result ->
125
+
(* Result messages become Complete events *)
126
+
[ Complete (Complete.of_result result) ]
+156
lib/response.mli
+156
lib/response.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** High-level response events from Claude.
7
+
8
+
This module provides a unified interface for handling different types of
9
+
responses from Claude. It converts low-level message and content block types
10
+
into high-level response events that are easier to work with in application
11
+
code. *)
12
+
13
+
(** {1 Response Event Types} *)
14
+
15
+
module Text : sig
16
+
(** Text content from the assistant. *)
17
+
18
+
type t
19
+
(** The type of text response events (opaque). *)
20
+
21
+
val content : t -> string
22
+
(** [content t] returns the text content. *)
23
+
24
+
val of_block : Content_block.Text.t -> t
25
+
(** [of_block block] creates a text response from a content block. *)
26
+
end
27
+
28
+
module Tool_use : sig
29
+
(** Tool invocation request from the assistant. *)
30
+
31
+
type t
32
+
(** The type of tool use response events (opaque). *)
33
+
34
+
val id : t -> string
35
+
(** [id t] returns the unique identifier of the tool use. *)
36
+
37
+
val name : t -> string
38
+
(** [name t] returns the name of the tool being invoked. *)
39
+
40
+
val input : t -> Tool_input.t
41
+
(** [input t] returns the input parameters for the tool. *)
42
+
43
+
val of_block : Content_block.Tool_use.t -> t
44
+
(** [of_block block] creates a tool use response from a content block. *)
45
+
end
46
+
47
+
module Thinking : sig
48
+
(** Internal reasoning from the assistant. *)
49
+
50
+
type t
51
+
(** The type of thinking response events (opaque). *)
52
+
53
+
val content : t -> string
54
+
(** [content t] returns the thinking content. *)
55
+
56
+
val signature : t -> string
57
+
(** [signature t] returns the cryptographic signature. *)
58
+
59
+
val of_block : Content_block.Thinking.t -> t
60
+
(** [of_block block] creates a thinking response from a content block. *)
61
+
end
62
+
63
+
module Init : sig
64
+
(** Session initialization event. *)
65
+
66
+
type t
67
+
(** The type of init response events (opaque). *)
68
+
69
+
val session_id : t -> string option
70
+
(** [session_id t] returns the optional session identifier. *)
71
+
72
+
val model : t -> string option
73
+
(** [model t] returns the optional model name. *)
74
+
75
+
val cwd : t -> string option
76
+
(** [cwd t] returns the optional current working directory. *)
77
+
78
+
val of_system : Message.System.t -> t option
79
+
(** [of_system sys] returns Some if system message is init, None if error. *)
80
+
end
81
+
82
+
module Error : sig
83
+
(** Error events from system or assistant. *)
84
+
85
+
type t
86
+
(** The type of error response events (opaque). *)
87
+
88
+
val message : t -> string
89
+
(** [message t] returns the error message. *)
90
+
91
+
val is_system_error : t -> bool
92
+
(** [is_system_error t] returns true if this is a system error. *)
93
+
94
+
val is_assistant_error : t -> bool
95
+
(** [is_assistant_error t] returns true if this is an assistant error. *)
96
+
97
+
val of_system : Message.System.t -> t option
98
+
(** [of_system sys] returns Some if system message is error, None if init. *)
99
+
100
+
val of_assistant : Message.Assistant.t -> t option
101
+
(** [of_assistant msg] returns Some if assistant has error, None otherwise. *)
102
+
end
103
+
104
+
module Complete : sig
105
+
(** Session completion event with final results. *)
106
+
107
+
type t
108
+
(** The type of completion response events (opaque). *)
109
+
110
+
val duration_ms : t -> int
111
+
(** [duration_ms t] returns the total duration in milliseconds. *)
112
+
113
+
val num_turns : t -> int
114
+
(** [num_turns t] returns the number of conversation turns. *)
115
+
116
+
val session_id : t -> string
117
+
(** [session_id t] returns the session identifier. *)
118
+
119
+
val total_cost_usd : t -> float option
120
+
(** [total_cost_usd t] returns the optional total cost in USD. *)
121
+
122
+
val usage : t -> Message.Result.Usage.t option
123
+
(** [usage t] returns the optional usage statistics. *)
124
+
125
+
val result_text : t -> string option
126
+
(** [result_text t] returns the optional result string. *)
127
+
128
+
val structured_output : t -> Jsont.json option
129
+
(** [structured_output t] returns the optional structured JSON output. *)
130
+
131
+
val of_result : Message.Result.t -> t
132
+
(** [of_result result] creates a completion response from a result message. *)
133
+
end
134
+
135
+
(** {1 Response Event Union Type} *)
136
+
137
+
(** The type of response events that can be received from Claude. *)
138
+
type t =
139
+
| Text of Text.t (** Text content from assistant *)
140
+
| Tool_use of Tool_use.t (** Tool invocation request *)
141
+
| Tool_result of Content_block.Tool_result.t
142
+
(** Tool result (pass-through) *)
143
+
| Thinking of Thinking.t (** Internal reasoning *)
144
+
| Init of Init.t (** Session initialization *)
145
+
| Error of Error.t (** Error event *)
146
+
| Complete of Complete.t (** Session completion *)
147
+
148
+
val pp : Format.formatter -> t -> unit
149
+
(** [pp ppf t] pretty-prints the response event. *)
150
+
151
+
(** {1 Conversion} *)
152
+
153
+
val of_message : Message.t -> t list
154
+
(** [of_message msg] converts a message to response events. An assistant message
155
+
may produce multiple events (one per content block). User messages produce
156
+
empty lists since they are not responses. *)
+27
lib/server_info.ml
+27
lib/server_info.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
+
version : string;
8
+
capabilities : string list;
9
+
commands : string list;
10
+
output_styles : string list;
11
+
}
12
+
13
+
let version t = t.version
14
+
let capabilities t = t.capabilities
15
+
let commands t = t.commands
16
+
let output_styles t = t.output_styles
17
+
let has_capability t cap = List.mem cap t.capabilities
18
+
let supports_hooks t = has_capability t "hooks"
19
+
let supports_structured_output t = has_capability t "structured-output"
20
+
21
+
let of_control (c : Control.Server_info.t) : t =
22
+
{
23
+
version = Control.Server_info.version c;
24
+
capabilities = Control.Server_info.capabilities c;
25
+
commands = Control.Server_info.commands c;
26
+
output_styles = Control.Server_info.output_styles c;
27
+
}
+45
lib/server_info.mli
+45
lib/server_info.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Server capabilities and metadata.
7
+
8
+
This module provides a high-level interface for querying server capabilities
9
+
and metadata. It wraps the underlying protocol representation and provides
10
+
convenient accessors and capability checks. *)
11
+
12
+
(** {1 Server Information} *)
13
+
14
+
type t
15
+
(** Server metadata and capabilities. *)
16
+
17
+
val version : t -> string
18
+
(** [version t] returns the server version string. *)
19
+
20
+
val capabilities : t -> string list
21
+
(** [capabilities t] returns the list of available server capabilities. *)
22
+
23
+
val commands : t -> string list
24
+
(** [commands t] returns the list of available CLI commands. *)
25
+
26
+
val output_styles : t -> string list
27
+
(** [output_styles t] returns the list of supported output formats. *)
28
+
29
+
(** {1 Capability Checks} *)
30
+
31
+
val has_capability : t -> string -> bool
32
+
(** [has_capability t cap] returns true if the specified capability is
33
+
available. *)
34
+
35
+
val supports_hooks : t -> bool
36
+
(** [supports_hooks t] checks if the hooks capability is available. *)
37
+
38
+
val supports_structured_output : t -> bool
39
+
(** [supports_structured_output t] checks if the structured output capability is
40
+
available. *)
41
+
42
+
(** {1 Internal} *)
43
+
44
+
val of_control : Control.Server_info.t -> t
45
+
(** [of_control c] converts from the control protocol representation. *)
+40
lib/structured_output.ml
+40
lib/structured_output.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let src = Logs.Src.create "claude.structured_output" ~doc:"Structured output"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
type t = { json_schema : Jsont.json }
11
+
12
+
let pp ppf t = Jsont.pp_json ppf t.json_schema
13
+
14
+
let json_to_string json =
15
+
match Jsont_bytesrw.encode_string' Jsont.json json with
16
+
| Ok str -> str
17
+
| Error err -> failwith (Jsont.Error.to_string err)
18
+
19
+
let of_json_schema schema =
20
+
Log.debug (fun m ->
21
+
m "Created output format from JSON schema: %s" (json_to_string schema));
22
+
{ json_schema = schema }
23
+
24
+
let json_schema t = t.json_schema
25
+
let to_json_schema = json_schema
26
+
27
+
let jsont : t Jsont.t =
28
+
Jsont.Object.map ~kind:"StructuredOutput" (fun json_schema -> { json_schema })
29
+
|> Jsont.Object.mem "jsonSchema" Jsont.json ~enc:(fun t -> t.json_schema)
30
+
|> Jsont.Object.finish
31
+
32
+
let to_json t =
33
+
match Jsont.Json.encode jsont t with
34
+
| Ok json -> json
35
+
| Error msg -> failwith ("Structured_output.to_json: " ^ msg)
36
+
37
+
let of_json json =
38
+
match Jsont.Json.decode jsont json with
39
+
| Ok t -> t
40
+
| Error msg -> raise (Invalid_argument ("Structured_output.of_json: " ^ msg))
+46
lib/structured_output.mli
+46
lib/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 structured output support for Claude, allowing you to
9
+
specify the expected output format using JSON schemas. When a structured
10
+
output format is configured, Claude will return its response in the
11
+
specified JSON format, validated against your schema. *)
12
+
13
+
val src : Logs.Src.t
14
+
(** The log source for structured output operations. *)
15
+
16
+
(** {1 Output Format Configuration} *)
17
+
18
+
type t
19
+
(** The type of structured output format configurations. *)
20
+
21
+
val pp : Format.formatter -> t -> unit
22
+
(** [pp ppf t] pretty-prints the structured output configuration. *)
23
+
24
+
val of_json_schema : Jsont.json -> t
25
+
(** [of_json_schema schema] creates an output format from a JSON Schema.
26
+
27
+
The schema should be a valid JSON Schema Draft 7 as a {!type:Jsont.json}
28
+
value. *)
29
+
30
+
val json_schema : t -> Jsont.json
31
+
(** [json_schema t] returns the underlying JSON Schema. *)
32
+
33
+
val to_json_schema : t -> Jsont.json
34
+
(** [to_json_schema t] is an alias of {!json_schema}. *)
35
+
36
+
val jsont : t Jsont.t
37
+
(** Codec for structured output format. *)
38
+
39
+
(** {1 Serialization} *)
40
+
41
+
val to_json : t -> Jsont.json
42
+
(** [to_json t] converts the output format to its JSON representation. *)
43
+
44
+
val of_json : Jsont.json -> t
45
+
(** [of_json json] parses an output format from JSON.
46
+
@raise Invalid_argument if the JSON is not a valid output format. *)
+75
lib/tool.ml
+75
lib/tool.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module J = Jsont.Json
7
+
8
+
type t = {
9
+
name : string;
10
+
description : string;
11
+
input_schema : Jsont.json;
12
+
handler : Tool_input.t -> (Jsont.json, string) result;
13
+
}
14
+
15
+
let v ~name ~description ~input_schema ~handler =
16
+
{ name; description; input_schema; handler }
17
+
18
+
let pp ppf t = Fmt.pf ppf "<tool:%s>" t.name
19
+
let name t = t.name
20
+
let description t = t.description
21
+
let input_schema t = t.input_schema
22
+
let call t input = t.handler input
23
+
24
+
(* Convenience constructors using Jsont.Json builders *)
25
+
26
+
let text_result s =
27
+
J.list
28
+
[
29
+
J.object'
30
+
[
31
+
J.mem (J.name "type") (J.string "text");
32
+
J.mem (J.name "text") (J.string s);
33
+
];
34
+
]
35
+
36
+
let error_result s =
37
+
J.list
38
+
[
39
+
J.object'
40
+
[
41
+
J.mem (J.name "type") (J.string "text");
42
+
J.mem (J.name "text") (J.string s);
43
+
J.mem (J.name "is_error") (J.bool true);
44
+
];
45
+
]
46
+
47
+
(* Schema helpers *)
48
+
49
+
let schema_string = J.object' [ J.mem (J.name "type") (J.string "string") ]
50
+
let schema_int = J.object' [ J.mem (J.name "type") (J.string "integer") ]
51
+
let schema_number = J.object' [ J.mem (J.name "type") (J.string "number") ]
52
+
let schema_bool = J.object' [ J.mem (J.name "type") (J.string "boolean") ]
53
+
54
+
let schema_array item_schema =
55
+
J.object'
56
+
[
57
+
J.mem (J.name "type") (J.string "array");
58
+
J.mem (J.name "items") item_schema;
59
+
]
60
+
61
+
let schema_string_enum values =
62
+
J.object'
63
+
[
64
+
J.mem (J.name "type") (J.string "string");
65
+
J.mem (J.name "enum") (J.list (List.map J.string values));
66
+
]
67
+
68
+
let schema_object props ~required =
69
+
J.object'
70
+
[
71
+
J.mem (J.name "type") (J.string "object");
72
+
J.mem (J.name "properties")
73
+
(J.object' (List.map (fun (k, v) -> J.mem (J.name k) v) props));
74
+
J.mem (J.name "required") (J.list (List.map J.string required));
75
+
]
+128
lib/tool.mli
+128
lib/tool.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Custom tool definitions for MCP servers.
7
+
8
+
Tools are functions that Claude can invoke. They run in-process within your
9
+
OCaml application via the MCP (Model Context Protocol).
10
+
11
+
{2 Basic Usage}
12
+
13
+
{[
14
+
let greet =
15
+
Tool.v ~name:"greet" ~description:"Greet a user by name"
16
+
~input_schema:
17
+
(`O
18
+
[
19
+
("type", `String "object");
20
+
("properties", `O [ ("name", `O [ ("type", `String "string") ]) ]);
21
+
("required", `A [ `String "name" ]);
22
+
])
23
+
~handler:(fun args ->
24
+
match Tool_input.string args "name" with
25
+
| Some name ->
26
+
Ok
27
+
(`A
28
+
[
29
+
`O
30
+
[
31
+
("type", `String "text");
32
+
("text", `String (Printf.sprintf "Hello, %s!" name));
33
+
];
34
+
])
35
+
| None -> Error "Missing 'name' parameter")
36
+
]}
37
+
38
+
{2 Tool Response Format}
39
+
40
+
Tool handlers return MCP-compatible content:
41
+
- Success: [Ok content] where content is JSON array of content blocks
42
+
- Error: [Error message] for error responses
43
+
44
+
Content blocks are typically:
45
+
{[
46
+
`A [ `O [ ("type", `String "text"); ("text", `String "result") ] ]
47
+
]} *)
48
+
49
+
type t
50
+
(** Abstract type for tool definitions. *)
51
+
52
+
val pp : Format.formatter -> t -> unit
53
+
(** [pp ppf t] pretty-prints the tool definition. *)
54
+
55
+
val v :
56
+
name:string ->
57
+
description:string ->
58
+
input_schema:Jsont.json ->
59
+
handler:(Tool_input.t -> (Jsont.json, string) result) ->
60
+
t
61
+
(** [v ~name ~description ~input_schema ~handler] creates a custom tool.
62
+
63
+
@param name
64
+
Unique tool identifier. Claude uses this in function calls. When
65
+
registered with an MCP server named "foo", the full tool name becomes
66
+
[mcp__foo__<name>].
67
+
@param description
68
+
Human-readable description. Helps Claude understand when to use the tool.
69
+
@param input_schema
70
+
JSON Schema defining input parameters. Should be a valid JSON Schema
71
+
object with "type", "properties", etc.
72
+
@param handler
73
+
Function that executes the tool. Receives tool input, returns content
74
+
array or error message. *)
75
+
76
+
val name : t -> string
77
+
(** [name t] returns the tool's name. *)
78
+
79
+
val description : t -> string
80
+
(** [description t] returns the tool's description. *)
81
+
82
+
val input_schema : t -> Jsont.json
83
+
(** [input_schema t] returns the JSON Schema for inputs. *)
84
+
85
+
val call : t -> Tool_input.t -> (Jsont.json, string) result
86
+
(** [call t input] invokes the tool handler with the given input. *)
87
+
88
+
(** {1 Convenience Constructors}
89
+
90
+
Helper functions for common tool patterns. *)
91
+
92
+
val text_result : string -> Jsont.json
93
+
(** [text_result s] creates a text content result:
94
+
[\`A [\`O ["type", \`String "text"; "text", \`String s]]]. *)
95
+
96
+
val error_result : string -> Jsont.json
97
+
(** [error_result s] creates an error content result with is_error flag. *)
98
+
99
+
(** {2 Schema Helpers}
100
+
101
+
Build JSON Schema objects more easily. *)
102
+
103
+
val schema_object :
104
+
(string * Jsont.json) list -> required:string list -> Jsont.json
105
+
(** [schema_object props ~required] creates an object schema.
106
+
{[
107
+
schema_object
108
+
[ ("name", schema_string); ("age", schema_int) ]
109
+
~required:[ "name" ]
110
+
]} *)
111
+
112
+
val schema_string : Jsont.json
113
+
(** [schema_string] is string type schema: [{"type": "string"}]. *)
114
+
115
+
val schema_int : Jsont.json
116
+
(** [schema_int] is integer type schema: [{"type": "integer"}]. *)
117
+
118
+
val schema_number : Jsont.json
119
+
(** [schema_number] is number type schema: [{"type": "number"}]. *)
120
+
121
+
val schema_bool : Jsont.json
122
+
(** [schema_bool] is boolean type schema: [{"type": "boolean"}]. *)
123
+
124
+
val schema_array : Jsont.json -> Jsont.json
125
+
(** [schema_array item_schema] creates array schema with given item type. *)
126
+
127
+
val schema_string_enum : string list -> Jsont.json
128
+
(** [schema_string_enum values] creates enum schema for string values. *)
+150
lib/tool_input.ml
+150
lib/tool_input.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Opaque tool input with typed accessors. *)
7
+
8
+
type t = Jsont.json
9
+
10
+
let pp = Jsont.pp_json
11
+
12
+
(** {1 Escape Hatch} *)
13
+
14
+
let to_json t = t
15
+
let of_json json = json
16
+
17
+
(** {1 Helper Functions} *)
18
+
19
+
(* Extract members from JSON object, or return empty list if not an object *)
20
+
let members = function Jsont.Object (members, _) -> members | _ -> []
21
+
22
+
(* Find a member by key in the object *)
23
+
let member key mems =
24
+
List.find_map
25
+
(fun ((name, _), value) -> if name = key then Some value else None)
26
+
mems
27
+
28
+
(** {1 Typed Accessors} *)
29
+
30
+
let string t key =
31
+
let mems = members t in
32
+
match member key mems with
33
+
| Some json -> (
34
+
match Jsont.Json.decode Jsont.string json with
35
+
| Ok s -> Some s
36
+
| Error _ -> None)
37
+
| None -> None
38
+
39
+
let int t key =
40
+
let mems = members t in
41
+
match member key mems with
42
+
| Some json -> (
43
+
match Jsont.Json.decode Jsont.int json with
44
+
| Ok i -> Some i
45
+
| Error _ -> None)
46
+
| None -> None
47
+
48
+
let bool t key =
49
+
let mems = members t in
50
+
match member key mems with
51
+
| Some json -> (
52
+
match Jsont.Json.decode Jsont.bool json with
53
+
| Ok b -> Some b
54
+
| Error _ -> None)
55
+
| None -> None
56
+
57
+
let float t key =
58
+
let mems = members t in
59
+
match member key mems with
60
+
| Some json -> (
61
+
match Jsont.Json.decode Jsont.number json with
62
+
| Ok f -> Some f
63
+
| Error _ -> None)
64
+
| None -> None
65
+
66
+
let string_list t key =
67
+
let mems = members t in
68
+
match member key mems with
69
+
| Some json -> (
70
+
match json with
71
+
| Jsont.Array (items, _) ->
72
+
let strings =
73
+
List.filter_map
74
+
(fun item ->
75
+
match Jsont.Json.decode Jsont.string item with
76
+
| Ok s -> Some s
77
+
| Error _ -> None)
78
+
items
79
+
in
80
+
(* Only return Some if all items were strings *)
81
+
if List.length strings = List.length items then Some strings else None
82
+
| _ -> None)
83
+
| None -> None
84
+
85
+
let keys t =
86
+
let mems = members t in
87
+
List.map (fun ((name, _), _) -> name) mems
88
+
89
+
let is_empty t =
90
+
match t with
91
+
| Jsont.Object ([], _) -> true
92
+
| Jsont.Object _ -> false
93
+
| _ -> true
94
+
95
+
(** {1 Construction} *)
96
+
97
+
let empty = Jsont.Object ([], Jsont.Meta.none)
98
+
99
+
let add_member key value t =
100
+
let mems = members t in
101
+
let new_member = ((key, Jsont.Meta.none), value) in
102
+
(* Replace existing member or add new one *)
103
+
let filtered_members = List.filter (fun ((name, _), _) -> name <> key) mems in
104
+
Jsont.Object (new_member :: filtered_members, Jsont.Meta.none)
105
+
106
+
let add_string key value t =
107
+
let json_value =
108
+
match Jsont.Json.encode Jsont.string value with
109
+
| Ok json -> json
110
+
| Error _ -> failwith "add_string: encoding failed"
111
+
in
112
+
add_member key json_value t
113
+
114
+
let add_int key value t =
115
+
let json_value =
116
+
match Jsont.Json.encode Jsont.int value with
117
+
| Ok json -> json
118
+
| Error _ -> failwith "add_int: encoding failed"
119
+
in
120
+
add_member key json_value t
121
+
122
+
let add_bool key value t =
123
+
let json_value =
124
+
match Jsont.Json.encode Jsont.bool value with
125
+
| Ok json -> json
126
+
| Error _ -> failwith "add_bool: encoding failed"
127
+
in
128
+
add_member key json_value t
129
+
130
+
let add_float key value t =
131
+
let json_value =
132
+
match Jsont.Json.encode Jsont.number value with
133
+
| Ok json -> json
134
+
| Error _ -> failwith "add_float: encoding failed"
135
+
in
136
+
add_member key json_value t
137
+
138
+
let of_assoc assoc =
139
+
let members =
140
+
List.map (fun (key, json) -> ((key, Jsont.Meta.none), json)) assoc
141
+
in
142
+
Jsont.Object (members, Jsont.Meta.none)
143
+
144
+
let of_string_pairs pairs =
145
+
let assoc =
146
+
List.map
147
+
(fun (key, value) -> (key, Jsont.String (value, Jsont.Meta.none)))
148
+
pairs
149
+
in
150
+
of_assoc assoc
+72
lib/tool_input.mli
+72
lib/tool_input.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Opaque tool input with typed accessors.
7
+
8
+
Tool inputs are JSON objects representing parameters passed to tools. This
9
+
module provides type-safe accessors while hiding the JSON structure from
10
+
most client code. *)
11
+
12
+
type t
13
+
(** Abstract type for tool inputs. *)
14
+
15
+
val pp : Format.formatter -> t -> unit
16
+
(** [pp ppf t] pretty-prints the tool input. *)
17
+
18
+
(** {1 Typed Accessors} *)
19
+
20
+
val string : t -> string -> string option
21
+
(** [string t key] returns the string value for [key], if present and a string.
22
+
*)
23
+
24
+
val int : t -> string -> int option
25
+
(** [int t key] returns the integer value for [key], if present and an int. *)
26
+
27
+
val bool : t -> string -> bool option
28
+
(** [bool t key] returns the boolean value for [key], if present and a bool. *)
29
+
30
+
val float : t -> string -> float option
31
+
(** [float t key] returns the float value for [key], if present and a float. *)
32
+
33
+
val string_list : t -> string -> string list option
34
+
(** [string_list t key] returns the string list for [key], if present and a list
35
+
of strings. *)
36
+
37
+
val keys : t -> string list
38
+
(** [keys t] returns all keys in the input. *)
39
+
40
+
val is_empty : t -> bool
41
+
(** [is_empty t] returns true if the input has no keys. *)
42
+
43
+
(** {1 Escape Hatch} *)
44
+
45
+
val to_json : t -> Jsont.json
46
+
(** [to_json t] returns the underlying JSON for advanced use cases. *)
47
+
48
+
val of_json : Jsont.json -> t
49
+
(** [of_json json] wraps JSON as a tool input. *)
50
+
51
+
(** {1 Construction} *)
52
+
53
+
val empty : t
54
+
(** [empty] is an empty tool input. *)
55
+
56
+
val add_string : string -> string -> t -> t
57
+
(** [add_string key value t] adds a string field. *)
58
+
59
+
val add_int : string -> int -> t -> t
60
+
(** [add_int key value t] adds an integer field. *)
61
+
62
+
val add_bool : string -> bool -> t -> t
63
+
(** [add_bool key value t] adds a boolean field. *)
64
+
65
+
val add_float : string -> float -> t -> t
66
+
(** [add_float key value t] adds a float field. *)
67
+
68
+
val of_assoc : (string * Jsont.json) list -> t
69
+
(** [of_assoc assoc] creates tool input from an association list. *)
70
+
71
+
val of_string_pairs : (string * string) list -> t
72
+
(** [of_string_pairs pairs] creates tool input from string key-value pairs. *)
+210
lib/transport.ml
+210
lib/transport.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 "claude.transport" ~doc:"Claude transport layer"
9
+
10
+
module Log = (val Logs.src_log src : Logs.LOG)
11
+
12
+
exception CLI_not_found of string
13
+
exception Process_error of string
14
+
exception Connection_error of string
15
+
16
+
type process = P : _ Eio.Process.t -> process
17
+
18
+
type t = {
19
+
process : process;
20
+
stdin : Eio.Flow.sink_ty r;
21
+
stdin_close : [ `Close | `Flow ] r;
22
+
stdout : Eio.Buf_read.t;
23
+
}
24
+
25
+
let setting_source_to_string = function
26
+
| Options.Wire.User -> "user"
27
+
| Options.Wire.Project -> "project"
28
+
| Options.Wire.Local -> "local"
29
+
30
+
let add_flag flag opt cmd =
31
+
match opt with None -> cmd | Some v -> cmd @ [ flag; v ]
32
+
33
+
let add_list flag list cmd =
34
+
match list with [] -> cmd | items -> cmd @ [ flag; String.concat "," items ]
35
+
36
+
let build_command ~claude_path ~options =
37
+
[ claude_path; "--output-format"; "stream-json"; "--verbose" ]
38
+
|> add_flag "--system-prompt" (Options.system_prompt options)
39
+
|> add_flag "--append-system-prompt" (Options.append_system_prompt options)
40
+
|> add_list "--allowedTools" (Options.allowed_tools options)
41
+
|> add_list "--disallowedTools" (Options.disallowed_tools options)
42
+
|> add_flag "--model" (Option.map Model.to_string (Options.model options))
43
+
|> add_flag "--permission-mode"
44
+
(Option.map Permissions.Mode.to_string (Options.permission_mode options))
45
+
|> add_flag "--permission-prompt-tool"
46
+
(Options.permission_prompt_tool_name options)
47
+
|> add_flag "--max-budget-usd"
48
+
(Option.map Float.to_string (Options.max_budget_usd options))
49
+
|> add_flag "--fallback-model"
50
+
(Option.map Model.to_string (Options.fallback_model options))
51
+
|> add_flag "--setting-sources"
52
+
(Option.map
53
+
(fun sources ->
54
+
String.concat "," (List.map setting_source_to_string sources))
55
+
(Options.setting_sources options))
56
+
|> add_flag "--json-schema"
57
+
(Option.map
58
+
(fun format ->
59
+
let schema = Structured_output.to_json_schema format in
60
+
match Jsont_bytesrw.encode_string' Jsont.json schema with
61
+
| Ok s -> s
62
+
| Error err -> failwith (Jsont.Error.to_string err))
63
+
(Options.output_format options))
64
+
|> fun cmd -> cmd @ [ "--input-format"; "stream-json" ]
65
+
66
+
let build_environment ~options =
67
+
(* Preserve essential vars for Claude config/auth access *)
68
+
let home = Option.value (Sys.getenv_opt "HOME") ~default:"/tmp" in
69
+
let path = Option.value (Sys.getenv_opt "PATH") ~default:"/usr/bin:/bin" in
70
+
71
+
(* Preserve other potentially important environment variables *)
72
+
let preserve_vars =
73
+
[
74
+
"USER";
75
+
"LOGNAME";
76
+
"SHELL";
77
+
"TERM";
78
+
"XDG_CONFIG_HOME";
79
+
"XDG_DATA_HOME";
80
+
"XDG_CACHE_HOME";
81
+
"ANTHROPIC_API_KEY";
82
+
"CLAUDE_API_KEY" (* In case API key is set via env *);
83
+
]
84
+
in
85
+
86
+
let preserved =
87
+
List.filter_map
88
+
(fun var ->
89
+
Option.map (fun value -> Fmt.str "%s=%s" var value) (Sys.getenv_opt var))
90
+
preserve_vars
91
+
in
92
+
93
+
let base_env =
94
+
[
95
+
Fmt.str "HOME=%s" home;
96
+
Fmt.str "PATH=%s" path;
97
+
"CLAUDE_CODE_ENTRYPOINT=sdk-ocaml";
98
+
]
99
+
@ preserved
100
+
in
101
+
102
+
let custom_env =
103
+
List.map (fun (k, v) -> Fmt.str "%s=%s" k v) (Options.env options)
104
+
in
105
+
let env = Array.of_list (base_env @ custom_env) in
106
+
Log.debug (fun m -> m "Environment: HOME=%s, PATH=%s" home path);
107
+
Log.info (fun m ->
108
+
m "Full environment variables: %s"
109
+
(String.concat ", " (Array.to_list env)));
110
+
env
111
+
112
+
let spawn_process ~sw ~process_mgr ~env ~options ~cmd ~stdin_r ~stdout_w =
113
+
try
114
+
Log.info (fun m ->
115
+
m "Spawning claude with command: %s" (String.concat " " cmd));
116
+
Log.info (fun m -> m "Command arguments breakdown:");
117
+
List.iteri (fun i arg -> Log.info (fun m -> m " [%d]: %s" i arg)) cmd;
118
+
Eio.Process.spawn ~sw process_mgr ~env
119
+
~stdin:(stdin_r :> Eio.Flow.source_ty r)
120
+
~stdout:(stdout_w :> Eio.Flow.sink_ty r)
121
+
?cwd:(Options.cwd options) cmd
122
+
with exn ->
123
+
Log.err (fun m ->
124
+
m "Failed to spawn claude CLI: %s" (Printexc.to_string exn));
125
+
Log.err (fun m -> m "Make sure 'claude' is installed and authenticated");
126
+
Log.err (fun m -> m "You may need to run 'claude login' first");
127
+
raise
128
+
(CLI_not_found
129
+
(Fmt.str "Failed to spawn claude CLI: %s" (Printexc.to_string exn)))
130
+
131
+
let v ~sw ~process_mgr ~options () =
132
+
let claude_path = "claude" in
133
+
let cmd = build_command ~claude_path ~options in
134
+
let env = build_environment ~options in
135
+
136
+
let stdin_r, stdin_w = Eio.Process.pipe ~sw process_mgr in
137
+
let stdout_r, stdout_w = Eio.Process.pipe ~sw process_mgr in
138
+
let stderr_r, stderr_w = Eio.Process.pipe ~sw process_mgr in
139
+
(* Close stderr pipes - we don't need them *)
140
+
Eio.Flow.close stderr_r;
141
+
Eio.Flow.close stderr_w;
142
+
143
+
let process =
144
+
spawn_process ~sw ~process_mgr ~env ~options ~cmd ~stdin_r ~stdout_w
145
+
in
146
+
147
+
let stdin = (stdin_w :> Eio.Flow.sink_ty r) in
148
+
let stdin_close = (stdin_w :> [ `Close | `Flow ] r) in
149
+
let max_size =
150
+
match Options.max_buffer_size options with
151
+
| Some size -> size
152
+
| None -> 100_000_000 (* Default 100MB *)
153
+
in
154
+
let stdout =
155
+
Eio.Buf_read.of_flow ~max_size (stdout_r :> Eio.Flow.source_ty r)
156
+
in
157
+
158
+
{ process = P process; stdin; stdin_close; stdout }
159
+
160
+
let send t json =
161
+
let data =
162
+
match Jsont_bytesrw.encode_string' Jsont.json json with
163
+
| Ok s -> s
164
+
| Error err -> failwith (Jsont.Error.to_string err)
165
+
in
166
+
Log.debug (fun m -> m "Sending: %s" data);
167
+
try Eio.Flow.write t.stdin [ Cstruct.of_string (data ^ "\n") ]
168
+
with exn ->
169
+
Log.err (fun m -> m "Failed to send message: %s" (Printexc.to_string exn));
170
+
raise
171
+
(Connection_error
172
+
(Fmt.str "Failed to send message: %s" (Printexc.to_string exn)))
173
+
174
+
let receive_line t =
175
+
try
176
+
match Eio.Buf_read.line t.stdout with
177
+
| line ->
178
+
Log.debug (fun m -> m "Raw JSON: %s" line);
179
+
Some line
180
+
| exception End_of_file ->
181
+
Log.debug (fun m -> m "Received EOF");
182
+
None
183
+
with exn ->
184
+
Log.err (fun m ->
185
+
m "Failed to receive message: %s" (Printexc.to_string exn));
186
+
raise
187
+
(Connection_error
188
+
(Fmt.str "Failed to receive message: %s" (Printexc.to_string exn)))
189
+
190
+
let interrupt t =
191
+
Log.info (fun m -> m "Sending interrupt signal");
192
+
let request = Control.Request.interrupt () in
193
+
let envelope : Control.control_request =
194
+
{
195
+
type_ = `Control_request;
196
+
request_id = "";
197
+
request;
198
+
unknown = Unknown.empty;
199
+
}
200
+
in
201
+
let outgoing = Outgoing.Control_request envelope in
202
+
let interrupt_msg = Outgoing.to_json outgoing in
203
+
send t interrupt_msg
204
+
205
+
let close t =
206
+
try
207
+
Eio.Flow.close t.stdin_close;
208
+
let (P process) = t.process in
209
+
Eio.Process.await_exn process
210
+
with Eio.Io _ -> ()
+35
lib/transport.mli
+35
lib/transport.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Claude CLI process transport. *)
7
+
8
+
val src : Logs.Src.t
9
+
(** The log source for transport operations. *)
10
+
11
+
exception CLI_not_found of string
12
+
exception Process_error of string
13
+
exception Connection_error of string
14
+
15
+
type t
16
+
17
+
val v :
18
+
sw:Eio.Switch.t ->
19
+
process_mgr:_ Eio.Process.mgr ->
20
+
options:Options.t ->
21
+
unit ->
22
+
t
23
+
(** [v ~sw ~process_mgr ~options ()] creates a new transport. *)
24
+
25
+
val send : t -> Jsont.json -> unit
26
+
(** Send a JSON message. *)
27
+
28
+
val receive_line : t -> string option
29
+
(** Receive a line from the transport. *)
30
+
31
+
val interrupt : t -> unit
32
+
(** Send an interrupt signal. *)
33
+
34
+
val close : t -> unit
35
+
(** Close the transport. *)
+52
lib/unknown.ml
+52
lib/unknown.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type t = (string * Jsont.json) list
7
+
8
+
let pp ppf t =
9
+
let pp_pair ppf (k, v) = Fmt.pf ppf "@[%s: %a@]" k Jsont.pp_json v in
10
+
Fmt.pf ppf "@[{%a}@]"
11
+
(Fmt.list ~sep:(fun ppf () -> Fmt.pf ppf ",@ ") pp_pair)
12
+
t
13
+
14
+
let empty = []
15
+
let is_empty = function [] -> true | _ -> false
16
+
let of_assoc x = x
17
+
let to_assoc x = x
18
+
19
+
let jsont =
20
+
let open Jsont in
21
+
let dec obj =
22
+
match obj with
23
+
| Object (fields, _) ->
24
+
List.map (fun ((name, _meta), json) -> (name, json)) fields
25
+
| _ -> invalid_arg "Expected object"
26
+
in
27
+
let enc fields =
28
+
let mems =
29
+
List.map (fun (name, json) -> ((name, Meta.none), json)) fields
30
+
in
31
+
Object (mems, Meta.none)
32
+
in
33
+
map ~dec ~enc json
34
+
35
+
let mems : (t, Jsont.json, Jsont.mem list) Jsont.Object.Mems.map =
36
+
let open Jsont in
37
+
let dec_empty () = [] in
38
+
let dec_add meta name json acc = ((name, meta), json) :: acc in
39
+
let dec_finish _meta mems =
40
+
List.rev_map (fun ((name, _meta), json) -> (name, json)) mems
41
+
in
42
+
let enc =
43
+
{
44
+
Object.Mems.enc =
45
+
(fun k fields acc ->
46
+
List.fold_left
47
+
(fun acc (name, json) -> k Meta.none name json acc)
48
+
acc fields);
49
+
}
50
+
in
51
+
Object.Mems.map ~kind:"Unknown" ~dec_empty ~dec_add ~dec_finish ~enc
52
+
Jsont.json
+36
lib/unknown.mli
+36
lib/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. Useful for preserving fields that are not part of the
11
+
defined schema but should be maintained when reading and writing JSON. *)
12
+
13
+
type t
14
+
(** The opaque type of unknown fields, stored as an association list of field
15
+
names to JSON values. *)
16
+
17
+
val pp : Format.formatter -> t -> unit
18
+
(** [pp ppf t] pretty-prints the unknown fields. *)
19
+
20
+
val empty : t
21
+
(** [empty] is an empty set of unknown fields. *)
22
+
23
+
val is_empty : t -> bool
24
+
(** [is_empty t] returns [true] if there are no unknown fields stored in [t]. *)
25
+
26
+
val of_assoc : (string * Jsont.json) list -> t
27
+
(** [of_assoc assoc] creates unknown fields from an association list. *)
28
+
29
+
val to_assoc : t -> (string * Jsont.json) list
30
+
(** [to_assoc t] returns the association list of unknown fields. *)
31
+
32
+
val jsont : t Jsont.t
33
+
(** [jsont] is a codec for encoding and decoding unknown fields to/from JSON. *)
34
+
35
+
val mems : (t, Jsont.json, Jsont.mem list) Jsont.Object.Mems.map
36
+
(** [mems] is a mems codec for use with [Jsont.Object.keep_unknown]. *)
+15
test/interop/python_sdk/dune
+15
test/interop/python_sdk/dune
+1
test/interop/python_sdk/scripts/.gitignore
+1
test/interop/python_sdk/scripts/.gitignore
···
1
+
.venv/
+144
test/interop/python_sdk/scripts/generate.py
+144
test/interop/python_sdk/scripts/generate.py
···
1
+
"""Capture SDK control-protocol JSON from claude-agent-sdk.
2
+
3
+
Wires a fake Transport into claude_agent_sdk._internal.query.Query so
4
+
each call to a public control method (interrupt, set_model,
5
+
set_permission_mode, get_server_info, mcp_status, get_context_usage)
6
+
writes one JSON envelope that we save as a trace. The CLI is never
7
+
spawned.
8
+
9
+
Initialize is captured by patching Query.initialize to short-circuit
10
+
after the write (it normally awaits a response from the CLI).
11
+
"""
12
+
13
+
import asyncio
14
+
import json
15
+
import sys
16
+
from pathlib import Path
17
+
from typing import Any
18
+
19
+
from claude_agent_sdk._internal.query import Query
20
+
from claude_agent_sdk._internal.transport import Transport
21
+
from claude_agent_sdk import HookMatcher, HookContext
22
+
23
+
24
+
class CapturingTransport(Transport):
25
+
def __init__(self) -> None:
26
+
self.writes: list[str] = []
27
+
self.connected = True
28
+
29
+
async def connect(self) -> None:
30
+
return None
31
+
32
+
async def write(self, data: str) -> None:
33
+
self.writes.append(data)
34
+
35
+
def read_messages(self):
36
+
async def _empty():
37
+
if False:
38
+
yield {}
39
+
return _empty()
40
+
41
+
async def close(self) -> None:
42
+
self.connected = False
43
+
44
+
def is_ready(self) -> bool:
45
+
return self.connected
46
+
47
+
async def end_input(self) -> None:
48
+
return None
49
+
50
+
51
+
def take_json(transport: CapturingTransport) -> dict[str, Any]:
52
+
raw = transport.writes.pop()
53
+
return json.loads(raw.rstrip("\n"))
54
+
55
+
56
+
def normalise(envelope: dict[str, Any]) -> dict[str, Any]:
57
+
"""Replace the dynamic request_id with a fixed sentinel for stable diffs."""
58
+
if "request_id" in envelope:
59
+
envelope = dict(envelope)
60
+
envelope["request_id"] = "REQ_ID"
61
+
return envelope
62
+
63
+
64
+
async def capture_simple(transport: CapturingTransport, query: Query, name: str,
65
+
coro_factory) -> tuple[str, dict[str, Any]]:
66
+
task = asyncio.create_task(coro_factory())
67
+
await asyncio.sleep(0)
68
+
task.cancel()
69
+
try:
70
+
await task
71
+
except (asyncio.CancelledError, BaseException):
72
+
pass
73
+
return name, normalise(take_json(transport))
74
+
75
+
76
+
async def capture_initialize(transport: CapturingTransport, query: Query,
77
+
name: str) -> tuple[str, dict[str, Any]]:
78
+
async def hook(input_data, tool_use_id, context: HookContext):
79
+
return {}
80
+
81
+
query.hooks = {
82
+
"PreToolUse": [
83
+
{"matcher": "Bash", "hooks": [hook], "timeout": 5000},
84
+
],
85
+
}
86
+
task = asyncio.create_task(query.initialize())
87
+
await asyncio.sleep(0)
88
+
task.cancel()
89
+
try:
90
+
await task
91
+
except (asyncio.CancelledError, BaseException):
92
+
pass
93
+
return name, normalise(take_json(transport))
94
+
95
+
96
+
async def main(out_dir: Path) -> None:
97
+
out_dir.mkdir(parents=True, exist_ok=True)
98
+
99
+
captures: list[tuple[str, dict[str, Any]]] = []
100
+
101
+
transport = CapturingTransport()
102
+
query = Query(transport=transport, is_streaming_mode=True)
103
+
104
+
captures.append(await capture_simple(
105
+
transport, query, "interrupt", lambda: query.interrupt()))
106
+
captures.append(await capture_simple(
107
+
transport, query, "set_model_some",
108
+
lambda: query.set_model("claude-sonnet-4-5")))
109
+
captures.append(await capture_simple(
110
+
transport, query, "set_model_none",
111
+
lambda: query.set_model(None)))
112
+
captures.append(await capture_simple(
113
+
transport, query, "set_permission_mode",
114
+
lambda: query.set_permission_mode("acceptEdits")))
115
+
captures.append(await capture_simple(
116
+
transport, query, "mcp_status",
117
+
lambda: query.get_mcp_status()))
118
+
captures.append(await capture_simple(
119
+
transport, query, "context_usage",
120
+
lambda: query.get_context_usage()))
121
+
captures.append(await capture_simple(
122
+
transport, query, "rewind_files",
123
+
lambda: query.rewind_files("user_msg_42")))
124
+
captures.append(await capture_simple(
125
+
transport, query, "reconnect_mcp",
126
+
lambda: query.reconnect_mcp_server("my-server")))
127
+
captures.append(await capture_simple(
128
+
transport, query, "toggle_mcp_off",
129
+
lambda: query.toggle_mcp_server("my-server", False)))
130
+
captures.append(await capture_simple(
131
+
transport, query, "stop_task",
132
+
lambda: query.stop_task("task_xyz")))
133
+
134
+
captures.append(await capture_initialize(transport, query, "initialize"))
135
+
136
+
for name, envelope in captures:
137
+
path = out_dir / f"control_{name}.json"
138
+
path.write_text(json.dumps(envelope, indent=2, sort_keys=True) + "\n")
139
+
print(f"wrote {path.name}")
140
+
141
+
142
+
if __name__ == "__main__":
143
+
out_dir = Path(sys.argv[1]) if len(sys.argv) > 1 else Path("traces")
144
+
asyncio.run(main(out_dir))
+11
test/interop/python_sdk/scripts/generate.sh
+11
test/interop/python_sdk/scripts/generate.sh
···
1
+
#!/bin/bash
2
+
set -euo pipefail
3
+
SCRIPT_DIR="$(cd "$(dirname "$0")" && pwd)"
4
+
TRACE_DIR="$(cd "$SCRIPT_DIR/../traces" && pwd)"
5
+
6
+
cd "$SCRIPT_DIR"
7
+
if [ ! -d .venv ]; then
8
+
python3 -m venv .venv
9
+
.venv/bin/pip install --quiet -r requirements.txt
10
+
fi
11
+
.venv/bin/python3 generate.py "$TRACE_DIR"
+2
test/interop/python_sdk/scripts/requirements.txt
+2
test/interop/python_sdk/scripts/requirements.txt
+157
test/interop/python_sdk/test.ml
+157
test/interop/python_sdk/test.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Cross-implementation tests against claude-agent-sdk (Python).
7
+
8
+
Traces generated by: claude-agent-sdk 0.1.61
9
+
Regenerate: dune build @ocaml-claude/test/interop/python_sdk/regen-traces
10
+
11
+
For each control message Python's Query.* methods can emit, we:
12
+
1. Load the captured Python JSON envelope from traces/.
13
+
2. Build the equivalent envelope in OCaml using Claude.Control.
14
+
3. Encode to JSON, normalise the dynamic request_id to "REQ_ID",
15
+
and assert the two JSON values are structurally equal.
16
+
17
+
Known gaps: the Python SDK has methods OCaml does not model
18
+
(mcp_status, context_usage, rewind_files, reconnect_mcp_server,
19
+
toggle_mcp_server, stop_task, set_model(None)). For those, the
20
+
trace exists so the gap is visible but the OCaml side is skipped. *)
21
+
22
+
module C = Claude.Control
23
+
module M = Claude.Permissions.Mode
24
+
25
+
let read_file path =
26
+
let ic = open_in path in
27
+
let n = in_channel_length ic in
28
+
let s = really_input_string ic n in
29
+
close_in ic;
30
+
s
31
+
32
+
let trace name =
33
+
let path = Filename.concat "traces" ("control_" ^ name ^ ".json") in
34
+
match Jsont_bytesrw.decode_string' Jsont.json (read_file path) with
35
+
| Ok json -> json
36
+
| Error e -> Alcotest.failf "load %s: %s" path (Jsont.Error.to_string e)
37
+
38
+
let canonicalise json =
39
+
let rec go = function
40
+
| Jsont.Object (mems, meta) ->
41
+
let mems =
42
+
List.map
43
+
(fun ((name, name_meta), v) ->
44
+
let v' =
45
+
if name = "request_id" then
46
+
Jsont.String ("REQ_ID", Jsont.Meta.none)
47
+
else go v
48
+
in
49
+
((name, name_meta), v'))
50
+
mems
51
+
in
52
+
let sorted =
53
+
List.sort (fun ((a, _), _) ((b, _), _) -> String.compare a b) mems
54
+
in
55
+
Jsont.Object (sorted, meta)
56
+
| Jsont.Array (xs, meta) -> Jsont.Array (List.map go xs, meta)
57
+
| other -> other
58
+
in
59
+
go json
60
+
61
+
let to_string j =
62
+
match Jsont_bytesrw.encode_string' Jsont.json j with
63
+
| Ok s -> s
64
+
| Error e -> Alcotest.failf "encode: %s" (Jsont.Error.to_string e)
65
+
66
+
let assert_equal ~name ~expected ~got =
67
+
let e = to_string (canonicalise expected) in
68
+
let g = to_string (canonicalise got) in
69
+
if e <> g then
70
+
Alcotest.failf "%s mismatch:\n python: %s\n ocaml: %s" name e g
71
+
72
+
let envelope ~request =
73
+
let env : C.control_request =
74
+
{
75
+
type_ = `Control_request;
76
+
request_id = "REQ_ID";
77
+
request;
78
+
unknown = Claude.Unknown.empty;
79
+
}
80
+
in
81
+
Claude.Outgoing.to_json (Claude.Outgoing.Control_request env)
82
+
83
+
let test_interrupt () =
84
+
let expected = trace "interrupt" in
85
+
let got = envelope ~request:(C.Request.interrupt ()) in
86
+
assert_equal ~name:"interrupt" ~expected ~got
87
+
88
+
let test_set_model_some () =
89
+
let expected = trace "set_model_some" in
90
+
let got =
91
+
envelope ~request:(C.Request.set_model ~model:"claude-sonnet-4-5" ())
92
+
in
93
+
assert_equal ~name:"set_model_some" ~expected ~got
94
+
95
+
let test_set_permission_mode () =
96
+
let expected = trace "set_permission_mode" in
97
+
let got =
98
+
envelope ~request:(C.Request.set_permission_mode ~mode:M.Accept_edits ())
99
+
in
100
+
assert_equal ~name:"set_permission_mode" ~expected ~got
101
+
102
+
let json_object mems =
103
+
Jsont.Object
104
+
(List.map (fun (k, v) -> ((k, Jsont.Meta.none), v)) mems, Jsont.Meta.none)
105
+
106
+
let json_string s = Jsont.String (s, Jsont.Meta.none)
107
+
let json_int n = Jsont.Number (float_of_int n, Jsont.Meta.none)
108
+
let json_array xs = Jsont.Array (xs, Jsont.Meta.none)
109
+
110
+
let test_initialize () =
111
+
let expected = trace "initialize" in
112
+
let pre_tool_use =
113
+
json_array
114
+
[
115
+
json_object
116
+
[
117
+
("hookCallbackIds", json_array [ json_string "hook_0" ]);
118
+
("matcher", json_string "Bash");
119
+
("timeout", json_int 5000);
120
+
];
121
+
]
122
+
in
123
+
let hooks = [ ("PreToolUse", pre_tool_use) ] in
124
+
let got = envelope ~request:(C.Request.initialize ~hooks ()) in
125
+
assert_equal ~name:"initialize" ~expected ~got
126
+
127
+
let test_documents_unsupported subtype () =
128
+
(* These subtypes are emitted by claude-agent-sdk but not yet modelled
129
+
by Claude.Control.Request. The trace exists so the gap is visible;
130
+
OCaml cannot build them today. *)
131
+
let _ = trace subtype in
132
+
Alcotest.skip ()
133
+
134
+
let suite =
135
+
( "python_sdk_interop",
136
+
[
137
+
Alcotest.test_case "interrupt" `Quick test_interrupt;
138
+
Alcotest.test_case "set_model (some)" `Quick test_set_model_some;
139
+
Alcotest.test_case "set_permission_mode" `Quick test_set_permission_mode;
140
+
Alcotest.test_case "initialize" `Quick test_initialize;
141
+
Alcotest.test_case "set_model (none) - unsupported" `Quick
142
+
(test_documents_unsupported "set_model_none");
143
+
Alcotest.test_case "mcp_status - unsupported" `Quick
144
+
(test_documents_unsupported "mcp_status");
145
+
Alcotest.test_case "context_usage - unsupported" `Quick
146
+
(test_documents_unsupported "context_usage");
147
+
Alcotest.test_case "rewind_files - unsupported" `Quick
148
+
(test_documents_unsupported "rewind_files");
149
+
Alcotest.test_case "reconnect_mcp - unsupported" `Quick
150
+
(test_documents_unsupported "reconnect_mcp");
151
+
Alcotest.test_case "toggle_mcp_off - unsupported" `Quick
152
+
(test_documents_unsupported "toggle_mcp_off");
153
+
Alcotest.test_case "stop_task - unsupported" `Quick
154
+
(test_documents_unsupported "stop_task");
155
+
] )
156
+
157
+
let () = Alcotest.run "python_sdk_interop" [ suite ]
+7
test/interop/python_sdk/traces/control_context_usage.json
+7
test/interop/python_sdk/traces/control_context_usage.json
+18
test/interop/python_sdk/traces/control_initialize.json
+18
test/interop/python_sdk/traces/control_initialize.json
+7
test/interop/python_sdk/traces/control_interrupt.json
+7
test/interop/python_sdk/traces/control_interrupt.json
+7
test/interop/python_sdk/traces/control_mcp_status.json
+7
test/interop/python_sdk/traces/control_mcp_status.json
+8
test/interop/python_sdk/traces/control_reconnect_mcp.json
+8
test/interop/python_sdk/traces/control_reconnect_mcp.json
+8
test/interop/python_sdk/traces/control_rewind_files.json
+8
test/interop/python_sdk/traces/control_rewind_files.json
+8
test/interop/python_sdk/traces/control_set_model_none.json
+8
test/interop/python_sdk/traces/control_set_model_none.json
+8
test/interop/python_sdk/traces/control_set_model_some.json
+8
test/interop/python_sdk/traces/control_set_model_some.json
+8
test/interop/python_sdk/traces/control_set_permission_mode.json
+8
test/interop/python_sdk/traces/control_set_permission_mode.json
+8
test/interop/python_sdk/traces/control_stop_task.json
+8
test/interop/python_sdk/traces/control_stop_task.json
+9
test/interop/python_sdk/traces/control_toggle_mcp_off.json
+9
test/interop/python_sdk/traces/control_toggle_mcp_off.json
+26
test/test.ml
+26
test/test.ml
···
1
+
let () =
2
+
Vlog.setup_test ();
3
+
Alcotest.run "claude"
4
+
[
5
+
Test_claude.suite;
6
+
Test_client.suite;
7
+
Test_content_block.suite;
8
+
Test_control.suite;
9
+
Test_err.suite;
10
+
Test_handler.suite;
11
+
Test_hooks.suite;
12
+
Test_incoming.suite;
13
+
Test_mcp_server.suite;
14
+
Test_message.suite;
15
+
Test_model.suite;
16
+
Test_options.suite;
17
+
Test_outgoing.suite;
18
+
Test_permissions.suite;
19
+
Test_response.suite;
20
+
Test_server_info.suite;
21
+
Test_structured_output.suite;
22
+
Test_tool.suite;
23
+
Test_tool_input.suite;
24
+
Test_transport.suite;
25
+
Test_unknown.suite;
26
+
]
+560
test/test_claude.ml
+560
test/test_claude.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Consolidated unit tests for the Claude OCaml SDK.
7
+
8
+
This test suite covers:
9
+
- Protocol message encoding/decoding
10
+
- Tool module for custom tool definitions
11
+
- Mcp_server module for in-process MCP servers
12
+
- Structured error handling *)
13
+
14
+
module J = Jsont.Json
15
+
16
+
(* ============================================
17
+
Protocol Tests - Incoming message codec
18
+
============================================ *)
19
+
20
+
let test_decode_user_message () =
21
+
(* User messages from CLI come wrapped in a "message" envelope *)
22
+
let json_str = {|{"type":"user","message":{"content":"Hello"}}|} in
23
+
match Jsont_bytesrw.decode_string' Claude.Incoming.jsont json_str with
24
+
| Ok (Claude.Incoming.Message (Claude.Message.User _)) -> ()
25
+
| Ok _ -> Alcotest.fail "Wrong message type decoded"
26
+
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
27
+
28
+
let test_decode_assistant_message () =
29
+
(* Assistant messages from CLI come wrapped in a "message" envelope *)
30
+
let json_str =
31
+
{|{"type":"assistant","message":{"model":"claude-sonnet-4","content":[{"type":"text","text":"Hi"}]}}|}
32
+
in
33
+
match Jsont_bytesrw.decode_string' Claude.Incoming.jsont json_str with
34
+
| Ok (Claude.Incoming.Message (Claude.Message.Assistant _)) -> ()
35
+
| Ok _ -> Alcotest.fail "Wrong message type decoded"
36
+
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
37
+
38
+
let test_decode_system_message () =
39
+
let json_str =
40
+
{|{"type":"system","subtype":"init","data":{"session_id":"test-123"}}|}
41
+
in
42
+
match Jsont_bytesrw.decode_string' Claude.Incoming.jsont json_str with
43
+
| Ok (Claude.Incoming.Message (Claude.Message.System _)) -> ()
44
+
| Ok _ -> Alcotest.fail "Wrong message type decoded"
45
+
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
46
+
47
+
let test_decode_control_response_success () =
48
+
let json_str =
49
+
{|{"type":"control_response","response":{"subtype":"success","request_id":"test-req-1"}}|}
50
+
in
51
+
match Jsont_bytesrw.decode_string' Claude.Incoming.jsont json_str with
52
+
| Ok (Claude.Incoming.Control_response resp) -> (
53
+
match resp.response with
54
+
| Claude.Control.Response.Success s ->
55
+
Alcotest.(check string) "request_id" "test-req-1" s.request_id
56
+
| Claude.Control.Response.Error _ ->
57
+
Alcotest.fail "Got error response instead of success")
58
+
| Ok _ -> Alcotest.fail "Wrong message type decoded"
59
+
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
60
+
61
+
let test_decode_control_response_error () =
62
+
let json_str =
63
+
{|{"type":"control_response","response":{"subtype":"error","request_id":"test-req-2","error":{"code":-32603,"message":"Something went wrong"}}}|}
64
+
in
65
+
match Jsont_bytesrw.decode_string' Claude.Incoming.jsont json_str with
66
+
| Ok (Claude.Incoming.Control_response resp) -> (
67
+
match resp.response with
68
+
| Claude.Control.Response.Error e ->
69
+
Alcotest.(check string) "request_id" "test-req-2" e.request_id;
70
+
Alcotest.(check int) "error code" (-32603) e.error.code;
71
+
Alcotest.(check string)
72
+
"error message" "Something went wrong" e.error.message
73
+
| Claude.Control.Response.Success _ ->
74
+
Alcotest.fail "Got success response instead of error")
75
+
| Ok _ -> Alcotest.fail "Wrong message type decoded"
76
+
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
77
+
78
+
let protocol_tests =
79
+
[
80
+
Alcotest.test_case "decode user message" `Quick test_decode_user_message;
81
+
Alcotest.test_case "decode assistant message" `Quick
82
+
test_decode_assistant_message;
83
+
Alcotest.test_case "decode system message" `Quick test_decode_system_message;
84
+
Alcotest.test_case "decode control response success" `Quick
85
+
test_decode_control_response_success;
86
+
Alcotest.test_case "decode control response error" `Quick
87
+
test_decode_control_response_error;
88
+
]
89
+
90
+
(* ============================================
91
+
Tool Module Tests
92
+
============================================ *)
93
+
94
+
let json_testable =
95
+
Alcotest.testable
96
+
(fun fmt json ->
97
+
match Jsont_bytesrw.encode_string' Jsont.json json with
98
+
| Ok s -> Format.pp_print_string fmt s
99
+
| Error e -> Format.pp_print_string fmt (Jsont.Error.to_string e))
100
+
(fun a b ->
101
+
match
102
+
( Jsont_bytesrw.encode_string' Jsont.json a,
103
+
Jsont_bytesrw.encode_string' Jsont.json b )
104
+
with
105
+
| Ok sa, Ok sb -> String.equal sa sb
106
+
| _ -> false)
107
+
108
+
let test_tool_schema_string () =
109
+
let schema = Claude.Tool.schema_string in
110
+
let expected = J.object' [ J.mem (J.name "type") (J.string "string") ] in
111
+
Alcotest.check json_testable "schema_string" expected schema
112
+
113
+
let test_tool_schema_int () =
114
+
let schema = Claude.Tool.schema_int in
115
+
let expected = J.object' [ J.mem (J.name "type") (J.string "integer") ] in
116
+
Alcotest.check json_testable "schema_int" expected schema
117
+
118
+
let test_tool_schema_number () =
119
+
let schema = Claude.Tool.schema_number in
120
+
let expected = J.object' [ J.mem (J.name "type") (J.string "number") ] in
121
+
Alcotest.check json_testable "schema_number" expected schema
122
+
123
+
let test_tool_schema_bool () =
124
+
let schema = Claude.Tool.schema_bool in
125
+
let expected = J.object' [ J.mem (J.name "type") (J.string "boolean") ] in
126
+
Alcotest.check json_testable "schema_bool" expected schema
127
+
128
+
let test_tool_schema_array () =
129
+
let schema = Claude.Tool.schema_array Claude.Tool.schema_string in
130
+
let expected =
131
+
J.object'
132
+
[
133
+
J.mem (J.name "type") (J.string "array");
134
+
J.mem (J.name "items")
135
+
(J.object' [ J.mem (J.name "type") (J.string "string") ]);
136
+
]
137
+
in
138
+
Alcotest.check json_testable "schema_array" expected schema
139
+
140
+
let test_tool_schema_string_enum () =
141
+
let schema = Claude.Tool.schema_string_enum [ "foo"; "bar"; "baz" ] in
142
+
let expected =
143
+
J.object'
144
+
[
145
+
J.mem (J.name "type") (J.string "string");
146
+
J.mem (J.name "enum")
147
+
(J.list [ J.string "foo"; J.string "bar"; J.string "baz" ]);
148
+
]
149
+
in
150
+
Alcotest.check json_testable "schema_string_enum" expected schema
151
+
152
+
let test_tool_schema_object () =
153
+
let schema =
154
+
Claude.Tool.schema_object
155
+
[ ("name", Claude.Tool.schema_string); ("age", Claude.Tool.schema_int) ]
156
+
~required:[ "name" ]
157
+
in
158
+
let expected =
159
+
J.object'
160
+
[
161
+
J.mem (J.name "type") (J.string "object");
162
+
J.mem (J.name "properties")
163
+
(J.object'
164
+
[
165
+
J.mem (J.name "name")
166
+
(J.object' [ J.mem (J.name "type") (J.string "string") ]);
167
+
J.mem (J.name "age")
168
+
(J.object' [ J.mem (J.name "type") (J.string "integer") ]);
169
+
]);
170
+
J.mem (J.name "required") (J.list [ J.string "name" ]);
171
+
]
172
+
in
173
+
Alcotest.check json_testable "schema_object" expected schema
174
+
175
+
let test_tool_text_result () =
176
+
let result = Claude.Tool.text_result "Hello, world!" in
177
+
let expected =
178
+
J.list
179
+
[
180
+
J.object'
181
+
[
182
+
J.mem (J.name "type") (J.string "text");
183
+
J.mem (J.name "text") (J.string "Hello, world!");
184
+
];
185
+
]
186
+
in
187
+
Alcotest.check json_testable "text_result" expected result
188
+
189
+
let test_tool_error_result () =
190
+
let result = Claude.Tool.error_result "Something went wrong" in
191
+
let expected =
192
+
J.list
193
+
[
194
+
J.object'
195
+
[
196
+
J.mem (J.name "type") (J.string "text");
197
+
J.mem (J.name "text") (J.string "Something went wrong");
198
+
J.mem (J.name "is_error") (J.bool true);
199
+
];
200
+
]
201
+
in
202
+
Alcotest.check json_testable "error_result" expected result
203
+
204
+
let test_tool_create_and_call () =
205
+
let greet =
206
+
Claude.Tool.v ~name:"greet" ~description:"Greet a user"
207
+
~input_schema:
208
+
(Claude.Tool.schema_object
209
+
[ ("name", Claude.Tool.schema_string) ]
210
+
~required:[ "name" ])
211
+
~handler:(fun args ->
212
+
match Claude.Tool_input.string args "name" with
213
+
| Some name -> Ok (Claude.Tool.text_result ("Hello, " ^ name ^ "!"))
214
+
| None -> Error "Missing name parameter")
215
+
in
216
+
Alcotest.(check string) "tool name" "greet" (Claude.Tool.name greet);
217
+
Alcotest.(check string)
218
+
"tool description" "Greet a user"
219
+
(Claude.Tool.description greet);
220
+
221
+
(* Test successful call *)
222
+
let input_json = J.object' [ J.mem (J.name "name") (J.string "Alice") ] in
223
+
let input = Claude.Tool_input.of_json input_json in
224
+
match Claude.Tool.call greet input with
225
+
| Ok result ->
226
+
let expected = Claude.Tool.text_result "Hello, Alice!" in
227
+
Alcotest.check json_testable "call result" expected result
228
+
| Error msg -> Alcotest.fail msg
229
+
230
+
let test_tool_call_error () =
231
+
let tool =
232
+
Claude.Tool.v ~name:"fail" ~description:"Always fails"
233
+
~input_schema:(Claude.Tool.schema_object [] ~required:[])
234
+
~handler:(fun _ -> Error "Intentional failure")
235
+
in
236
+
let input = Claude.Tool_input.of_json (J.object' []) in
237
+
match Claude.Tool.call tool input with
238
+
| Ok _ -> Alcotest.fail "Expected error"
239
+
| Error msg ->
240
+
Alcotest.(check string) "error message" "Intentional failure" msg
241
+
242
+
let tool_tests =
243
+
[
244
+
Alcotest.test_case "schema_string" `Quick test_tool_schema_string;
245
+
Alcotest.test_case "schema_int" `Quick test_tool_schema_int;
246
+
Alcotest.test_case "schema_number" `Quick test_tool_schema_number;
247
+
Alcotest.test_case "schema_bool" `Quick test_tool_schema_bool;
248
+
Alcotest.test_case "schema_array" `Quick test_tool_schema_array;
249
+
Alcotest.test_case "schema_string_enum" `Quick test_tool_schema_string_enum;
250
+
Alcotest.test_case "schema_object" `Quick test_tool_schema_object;
251
+
Alcotest.test_case "text_result" `Quick test_tool_text_result;
252
+
Alcotest.test_case "error_result" `Quick test_tool_error_result;
253
+
Alcotest.test_case "create and call" `Quick test_tool_create_and_call;
254
+
Alcotest.test_case "call error" `Quick test_tool_call_error;
255
+
]
256
+
257
+
(* ============================================
258
+
Mcp_server Module Tests
259
+
============================================ *)
260
+
261
+
let test_mcp_server_create () =
262
+
let tool =
263
+
Claude.Tool.v ~name:"echo" ~description:"Echo input"
264
+
~input_schema:
265
+
(Claude.Tool.schema_object
266
+
[ ("text", Claude.Tool.schema_string) ]
267
+
~required:[ "text" ])
268
+
~handler:(fun args ->
269
+
match Claude.Tool_input.string args "text" with
270
+
| Some text -> Ok (Claude.Tool.text_result text)
271
+
| None -> Error "Missing text")
272
+
in
273
+
let server =
274
+
Claude.Mcp_server.v ~name:"test-server" ~version:"2.0.0" ~tools:[ tool ] ()
275
+
in
276
+
Alcotest.(check string)
277
+
"server name" "test-server"
278
+
(Claude.Mcp_server.name server);
279
+
Alcotest.(check string)
280
+
"server version" "2.0.0"
281
+
(Claude.Mcp_server.version server);
282
+
Alcotest.(check int)
283
+
"tools count" 1
284
+
(List.length (Claude.Mcp_server.tools server))
285
+
286
+
let test_mcp_server_initialize () =
287
+
let server = Claude.Mcp_server.v ~name:"init-test" ~tools:[] () in
288
+
let request =
289
+
J.object'
290
+
[
291
+
J.mem (J.name "jsonrpc") (J.string "2.0");
292
+
J.mem (J.name "id") (J.number 1.0);
293
+
J.mem (J.name "method") (J.string "initialize");
294
+
J.mem (J.name "params") (J.object' []);
295
+
]
296
+
in
297
+
let response = Claude.Mcp_server.handle_json_message server request in
298
+
(* Check it's a success response with serverInfo *)
299
+
match response with
300
+
| Jsont.Object (mems, _) ->
301
+
let has_result = List.exists (fun ((k, _), _) -> k = "result") mems in
302
+
Alcotest.(check bool) "has result" true has_result
303
+
| _ -> Alcotest.fail "Expected object response"
304
+
305
+
let test_mcp_server_tools_list () =
306
+
let tool =
307
+
Claude.Tool.v ~name:"my_tool" ~description:"My test tool"
308
+
~input_schema:(Claude.Tool.schema_object [] ~required:[])
309
+
~handler:(fun _ -> Ok (Claude.Tool.text_result "ok"))
310
+
in
311
+
let server = Claude.Mcp_server.v ~name:"list-test" ~tools:[ tool ] () in
312
+
let request =
313
+
J.object'
314
+
[
315
+
J.mem (J.name "jsonrpc") (J.string "2.0");
316
+
J.mem (J.name "id") (J.number 2.0);
317
+
J.mem (J.name "method") (J.string "tools/list");
318
+
J.mem (J.name "params") (J.object' []);
319
+
]
320
+
in
321
+
let response = Claude.Mcp_server.handle_json_message server request in
322
+
match response with
323
+
| Jsont.Object (mems, _) -> (
324
+
match List.find_opt (fun ((k, _), _) -> k = "result") mems with
325
+
| Some (_, Jsont.Object (result_mems, _)) -> (
326
+
match List.find_opt (fun ((k, _), _) -> k = "tools") result_mems with
327
+
| Some (_, Jsont.Array (tools, _)) ->
328
+
Alcotest.(check int) "tools count" 1 (List.length tools)
329
+
| _ -> Alcotest.fail "Missing tools in result")
330
+
| _ -> Alcotest.fail "Missing result in response")
331
+
| _ -> Alcotest.fail "Expected object response"
332
+
333
+
let test_mcp_server_tools_call () =
334
+
let tool =
335
+
Claude.Tool.v ~name:"uppercase" ~description:"Convert to uppercase"
336
+
~input_schema:
337
+
(Claude.Tool.schema_object
338
+
[ ("text", Claude.Tool.schema_string) ]
339
+
~required:[ "text" ])
340
+
~handler:(fun args ->
341
+
match Claude.Tool_input.string args "text" with
342
+
| Some text ->
343
+
Ok (Claude.Tool.text_result (String.uppercase_ascii text))
344
+
| None -> Error "Missing text")
345
+
in
346
+
let server = Claude.Mcp_server.v ~name:"call-test" ~tools:[ tool ] () in
347
+
let request =
348
+
J.object'
349
+
[
350
+
J.mem (J.name "jsonrpc") (J.string "2.0");
351
+
J.mem (J.name "id") (J.number 3.0);
352
+
J.mem (J.name "method") (J.string "tools/call");
353
+
J.mem (J.name "params")
354
+
(J.object'
355
+
[
356
+
J.mem (J.name "name") (J.string "uppercase");
357
+
J.mem (J.name "arguments")
358
+
(J.object' [ J.mem (J.name "text") (J.string "hello") ]);
359
+
]);
360
+
]
361
+
in
362
+
let response = Claude.Mcp_server.handle_json_message server request in
363
+
(* Verify it contains the expected uppercase result *)
364
+
let response_str =
365
+
match Jsont_bytesrw.encode_string' Jsont.json response with
366
+
| Ok s -> s
367
+
| Error _ -> ""
368
+
in
369
+
(* Simple substring check for HELLO in response *)
370
+
let contains_hello =
371
+
let rec check i =
372
+
if i + 5 > String.length response_str then false
373
+
else if String.sub response_str i 5 = "HELLO" then true
374
+
else check (i + 1)
375
+
in
376
+
check 0
377
+
in
378
+
Alcotest.(check bool) "contains HELLO" true contains_hello
379
+
380
+
let test_mcp_tool_not_found () =
381
+
let server = Claude.Mcp_server.v ~name:"notfound-test" ~tools:[] () in
382
+
let request =
383
+
J.object'
384
+
[
385
+
J.mem (J.name "jsonrpc") (J.string "2.0");
386
+
J.mem (J.name "id") (J.number 4.0);
387
+
J.mem (J.name "method") (J.string "tools/call");
388
+
J.mem (J.name "params")
389
+
(J.object' [ J.mem (J.name "name") (J.string "nonexistent") ]);
390
+
]
391
+
in
392
+
let response = Claude.Mcp_server.handle_json_message server request in
393
+
(* Should return an error response *)
394
+
match response with
395
+
| Jsont.Object (mems, _) ->
396
+
let has_error = List.exists (fun ((k, _), _) -> k = "error") mems in
397
+
Alcotest.(check bool) "has error" true has_error
398
+
| _ -> Alcotest.fail "Expected object response"
399
+
400
+
let test_mcp_method_not_found () =
401
+
let server = Claude.Mcp_server.v ~name:"method-notfound-test" ~tools:[] () in
402
+
let request =
403
+
J.object'
404
+
[
405
+
J.mem (J.name "jsonrpc") (J.string "2.0");
406
+
J.mem (J.name "id") (J.number 5.0);
407
+
J.mem (J.name "method") (J.string "unknown/method");
408
+
J.mem (J.name "params") (J.object' []);
409
+
]
410
+
in
411
+
let response = Claude.Mcp_server.handle_json_message server request in
412
+
match response with
413
+
| Jsont.Object (mems, _) ->
414
+
let has_error = List.exists (fun ((k, _), _) -> k = "error") mems in
415
+
Alcotest.(check bool) "has error" true has_error
416
+
| _ -> Alcotest.fail "Expected object response"
417
+
418
+
let mcp_server_tests =
419
+
[
420
+
Alcotest.test_case "create server" `Quick test_mcp_server_create;
421
+
Alcotest.test_case "initialize" `Quick test_mcp_server_initialize;
422
+
Alcotest.test_case "tools/list" `Quick test_mcp_server_tools_list;
423
+
Alcotest.test_case "tools/call" `Quick test_mcp_server_tools_call;
424
+
Alcotest.test_case "tool not found" `Quick test_mcp_tool_not_found;
425
+
Alcotest.test_case "method not found" `Quick test_mcp_method_not_found;
426
+
]
427
+
428
+
(* ============================================
429
+
Structured Error Tests
430
+
============================================ *)
431
+
432
+
let test_error_detail_creation () =
433
+
let error =
434
+
Claude.Control.Response.error_detail ~code:`Method_not_found
435
+
~message:"Method not found" ()
436
+
in
437
+
Alcotest.(check int) "error code" (-32601) error.code;
438
+
Alcotest.(check string) "error message" "Method not found" error.message
439
+
440
+
let test_error_code_conventions () =
441
+
let codes =
442
+
[
443
+
(`Parse_error, -32700);
444
+
(`Invalid_request, -32600);
445
+
(`Method_not_found, -32601);
446
+
(`Invalid_params, -32602);
447
+
(`Internal_error, -32603);
448
+
(`Custom 1, 1);
449
+
]
450
+
in
451
+
List.iter
452
+
(fun (code, expected_int) ->
453
+
let err = Claude.Control.Response.error_detail ~code ~message:"test" () in
454
+
Alcotest.(check int) "error code value" expected_int err.code)
455
+
codes
456
+
457
+
let test_error_response_encoding () =
458
+
let error_detail =
459
+
Claude.Control.Response.error_detail ~code:`Invalid_params
460
+
~message:"Invalid parameters" ()
461
+
in
462
+
let error_resp =
463
+
Claude.Control.Response.error ~request_id:"test-123" ~error:error_detail ()
464
+
in
465
+
match Jsont.Json.encode Claude.Control.Response.jsont error_resp with
466
+
| Ok json -> (
467
+
match Jsont.Json.decode Claude.Control.Response.jsont json with
468
+
| Ok (Claude.Control.Response.Error decoded) ->
469
+
Alcotest.(check string) "request_id" "test-123" decoded.request_id;
470
+
Alcotest.(check int) "error code" (-32602) decoded.error.code;
471
+
Alcotest.(check string)
472
+
"error message" "Invalid parameters" decoded.error.message
473
+
| Ok _ -> Alcotest.fail "Wrong response type decoded"
474
+
| Error e -> Alcotest.fail e)
475
+
| Error e -> Alcotest.fail e
476
+
477
+
let structured_error_tests =
478
+
[
479
+
Alcotest.test_case "error detail creation" `Quick test_error_detail_creation;
480
+
Alcotest.test_case "error code conventions" `Quick
481
+
test_error_code_conventions;
482
+
Alcotest.test_case "error response encoding" `Quick
483
+
test_error_response_encoding;
484
+
]
485
+
486
+
(* ============================================
487
+
Tool_input Tests
488
+
============================================ *)
489
+
490
+
let test_tool_input_string () =
491
+
let json = J.object' [ J.mem (J.name "foo") (J.string "bar") ] in
492
+
let input = Claude.Tool_input.of_json json in
493
+
Alcotest.(check (option string))
494
+
"string foo" (Some "bar")
495
+
(Claude.Tool_input.string input "foo");
496
+
Alcotest.(check (option string))
497
+
"string missing" None
498
+
(Claude.Tool_input.string input "missing")
499
+
500
+
let test_tool_input_int () =
501
+
let json = J.object' [ J.mem (J.name "count") (J.number 42.0) ] in
502
+
let input = Claude.Tool_input.of_json json in
503
+
Alcotest.(check (option int))
504
+
"int count" (Some 42)
505
+
(Claude.Tool_input.int input "count")
506
+
507
+
let test_tool_input_float () =
508
+
let json = J.object' [ J.mem (J.name "pi") (J.number 3.14159) ] in
509
+
let input = Claude.Tool_input.of_json json in
510
+
match Claude.Tool_input.float input "pi" with
511
+
| Some f ->
512
+
Alcotest.(check bool)
513
+
"float pi approx" true
514
+
(abs_float (f -. 3.14159) < 0.0001)
515
+
| None -> Alcotest.fail "Expected float"
516
+
517
+
let test_tool_input_bool () =
518
+
let json =
519
+
J.object'
520
+
[ J.mem (J.name "yes") (J.bool true); J.mem (J.name "no") (J.bool false) ]
521
+
in
522
+
let input = Claude.Tool_input.of_json json in
523
+
Alcotest.(check (option bool))
524
+
"bool yes" (Some true)
525
+
(Claude.Tool_input.bool input "yes");
526
+
Alcotest.(check (option bool))
527
+
"bool no" (Some false)
528
+
(Claude.Tool_input.bool input "no")
529
+
530
+
let test_tool_input_string_list () =
531
+
let json =
532
+
J.object'
533
+
[
534
+
J.mem (J.name "items")
535
+
(J.list [ J.string "a"; J.string "b"; J.string "c" ]);
536
+
]
537
+
in
538
+
let input = Claude.Tool_input.of_json json in
539
+
Alcotest.(check (option (list string)))
540
+
"string_list"
541
+
(Some [ "a"; "b"; "c" ])
542
+
(Claude.Tool_input.string_list input "items")
543
+
544
+
let tool_input_tests =
545
+
[
546
+
Alcotest.test_case "string" `Quick test_tool_input_string;
547
+
Alcotest.test_case "int" `Quick test_tool_input_int;
548
+
Alcotest.test_case "float" `Quick test_tool_input_float;
549
+
Alcotest.test_case "bool" `Quick test_tool_input_bool;
550
+
Alcotest.test_case "string_list" `Quick test_tool_input_string_list;
551
+
]
552
+
553
+
(* ============================================
554
+
Main test runner
555
+
============================================ *)
556
+
557
+
let suite =
558
+
( "claude",
559
+
protocol_tests @ tool_tests @ mcp_server_tests @ structured_error_tests
560
+
@ tool_input_tests )
+2
test/test_claude.mli
+2
test/test_claude.mli
+17
test/test_client.ml
+17
test/test_client.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Client module: pure helpers only (no I/O). The Client module is
7
+
I/O heavy and requires Eio, so we test what we can without spawning
8
+
processes. *)
9
+
10
+
(* Client.src is a log source - verify it exists *)
11
+
let test_log_source_exists () =
12
+
let name = Logs.Src.name Claude.Client.src in
13
+
Alcotest.(check bool) "has name" true (String.length name > 0)
14
+
15
+
let suite =
16
+
( "client",
17
+
[ Alcotest.test_case "log source exists" `Quick test_log_source_exists ] )
+2
test/test_client.mli
+2
test/test_client.mli
+121
test/test_content_block.ml
+121
test/test_content_block.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Content_block module: constructors, accessors, proto roundtrip. *)
7
+
8
+
module CB = Claude.Content_block
9
+
10
+
let test_text_block () =
11
+
match CB.text "hello world" with
12
+
| CB.Text t -> Alcotest.(check string) "text" "hello world" (CB.Text.text t)
13
+
| _ -> Alcotest.fail "Expected Text block"
14
+
15
+
let test_tool_use_block () =
16
+
let input =
17
+
Claude.Tool_input.empty |> Claude.Tool_input.add_string "cmd" "ls"
18
+
in
19
+
match CB.tool_use ~id:"tu-1" ~name:"Bash" ~input with
20
+
| CB.Tool_use tu ->
21
+
Alcotest.(check string) "id" "tu-1" (CB.Tool_use.id tu);
22
+
Alcotest.(check string) "name" "Bash" (CB.Tool_use.name tu);
23
+
Alcotest.(check (option string))
24
+
"input cmd" (Some "ls")
25
+
(Claude.Tool_input.string (CB.Tool_use.input tu) "cmd")
26
+
| _ -> Alcotest.fail "Expected Tool_use block"
27
+
28
+
let test_tool_result_block () =
29
+
let content = Jsont.Json.string "success" in
30
+
match CB.tool_result ~tool_use_id:"tu-1" ~content () with
31
+
| CB.Tool_result tr ->
32
+
Alcotest.(check string)
33
+
"tool_use_id" "tu-1"
34
+
(CB.Tool_result.tool_use_id tr);
35
+
Alcotest.(check bool)
36
+
"has content" true
37
+
(Option.is_some (CB.Tool_result.content tr))
38
+
| _ -> Alcotest.fail "Expected Tool_result block"
39
+
40
+
let test_tool_result_with_error () =
41
+
match CB.tool_result ~tool_use_id:"tu-2" ~is_error:true () with
42
+
| CB.Tool_result tr ->
43
+
Alcotest.(check (option bool))
44
+
"is_error" (Some true)
45
+
(CB.Tool_result.is_error tr)
46
+
| _ -> Alcotest.fail "Expected Tool_result block"
47
+
48
+
let test_tool_result_no_content () =
49
+
match CB.tool_result ~tool_use_id:"tu-3" () with
50
+
| CB.Tool_result tr ->
51
+
Alcotest.(check bool)
52
+
"no content" true
53
+
(Option.is_none (CB.Tool_result.content tr))
54
+
| _ -> Alcotest.fail "Expected Tool_result block"
55
+
56
+
let test_thinking_block () =
57
+
match CB.thinking ~thinking:"I need to think..." ~signature:"sig123" with
58
+
| CB.Thinking t ->
59
+
Alcotest.(check string)
60
+
"thinking" "I need to think..." (CB.Thinking.thinking t);
61
+
Alcotest.(check string) "signature" "sig123" (CB.Thinking.signature t)
62
+
| _ -> Alcotest.fail "Expected Thinking block"
63
+
64
+
let json_roundtrip block =
65
+
match Jsont.Json.encode CB.jsont block with
66
+
| Ok json -> (
67
+
match Jsont.Json.decode CB.jsont json with
68
+
| Ok back -> back
69
+
| Error e -> Alcotest.fail e)
70
+
| Error e -> Alcotest.fail e
71
+
72
+
let test_jsont_roundtrip_text () =
73
+
let block = CB.text "roundtrip test" in
74
+
match json_roundtrip block with
75
+
| CB.Text t ->
76
+
Alcotest.(check string) "text" "roundtrip test" (CB.Text.text t)
77
+
| _ -> Alcotest.fail "Expected Text after roundtrip"
78
+
79
+
let test_jsont_roundtrip_tool_use () =
80
+
let input = Claude.Tool_input.empty |> Claude.Tool_input.add_string "f" "v" in
81
+
let block = CB.tool_use ~id:"id-1" ~name:"MyTool" ~input in
82
+
match json_roundtrip block with
83
+
| CB.Tool_use tu ->
84
+
Alcotest.(check string) "id" "id-1" (CB.Tool_use.id tu);
85
+
Alcotest.(check string) "name" "MyTool" (CB.Tool_use.name tu)
86
+
| _ -> Alcotest.fail "Expected Tool_use after roundtrip"
87
+
88
+
let test_jsont_roundtrip_thinking () =
89
+
let block = CB.thinking ~thinking:"hmm" ~signature:"s" in
90
+
match json_roundtrip block with
91
+
| CB.Thinking t ->
92
+
Alcotest.(check string) "thinking" "hmm" (CB.Thinking.thinking t);
93
+
Alcotest.(check string) "signature" "s" (CB.Thinking.signature t)
94
+
| _ -> Alcotest.fail "Expected Thinking after roundtrip"
95
+
96
+
let test_pp_does_not_crash () =
97
+
let block = CB.text "pp test" in
98
+
let buf = Buffer.create 64 in
99
+
let ppf = Format.formatter_of_buffer buf in
100
+
CB.pp ppf block;
101
+
Format.pp_print_flush ppf ();
102
+
Alcotest.(check bool) "pp output" true (Buffer.contents buf <> "")
103
+
104
+
let suite =
105
+
( "content_block",
106
+
[
107
+
Alcotest.test_case "text block" `Quick test_text_block;
108
+
Alcotest.test_case "tool_use block" `Quick test_tool_use_block;
109
+
Alcotest.test_case "tool_result block" `Quick test_tool_result_block;
110
+
Alcotest.test_case "tool_result with error" `Quick
111
+
test_tool_result_with_error;
112
+
Alcotest.test_case "tool_result no content" `Quick
113
+
test_tool_result_no_content;
114
+
Alcotest.test_case "thinking block" `Quick test_thinking_block;
115
+
Alcotest.test_case "jsont roundtrip text" `Quick test_jsont_roundtrip_text;
116
+
Alcotest.test_case "jsont roundtrip tool_use" `Quick
117
+
test_jsont_roundtrip_tool_use;
118
+
Alcotest.test_case "jsont roundtrip thinking" `Quick
119
+
test_jsont_roundtrip_thinking;
120
+
Alcotest.test_case "pp does not crash" `Quick test_pp_does_not_crash;
121
+
] )
+2
test/test_content_block.mli
+2
test/test_content_block.mli
+316
test/test_control.ml
+316
test/test_control.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module C = Claude.Control
7
+
8
+
let test_interrupt_request () =
9
+
match C.Request.interrupt () with
10
+
| C.Request.Interrupt _ -> ()
11
+
| _ -> Alcotest.fail "Expected Interrupt"
12
+
13
+
let test_permission_request () =
14
+
let input = Jsont.Json.object' [] in
15
+
match C.Request.permission ~tool_name:"Bash" ~input () with
16
+
| C.Request.Permission p ->
17
+
Alcotest.(check string) "tool_name" "Bash" p.tool_name
18
+
| _ -> Alcotest.fail "Expected Permission"
19
+
20
+
let test_initialize_request () =
21
+
match C.Request.initialize () with
22
+
| C.Request.Initialize _ -> ()
23
+
| _ -> Alcotest.fail "Expected Initialize"
24
+
25
+
let test_set_permission_mode_request () =
26
+
match
27
+
C.Request.set_permission_mode ~mode:Claude.Permissions.Mode.Accept_edits ()
28
+
with
29
+
| C.Request.Set_permission_mode spm ->
30
+
Alcotest.(check string)
31
+
"mode" "acceptEdits"
32
+
(Claude.Permissions.Mode.to_string spm.mode)
33
+
| _ -> Alcotest.fail "Expected Set_permission_mode"
34
+
35
+
let test_set_model_request () =
36
+
match C.Request.set_model ~model:"claude-opus-4" () with
37
+
| C.Request.Set_model sm ->
38
+
Alcotest.(check string) "model" "claude-opus-4" sm.model
39
+
| _ -> Alcotest.fail "Expected Set_model"
40
+
41
+
let test_get_server_info_request () =
42
+
match C.Request.get_server_info () with
43
+
| C.Request.Get_server_info _ -> ()
44
+
| _ -> Alcotest.fail "Expected Get_server_info"
45
+
46
+
let test_success_response () =
47
+
match C.Response.success ~request_id:"req-1" () with
48
+
| C.Response.Success s ->
49
+
Alcotest.(check string) "request_id" "req-1" s.request_id
50
+
| _ -> Alcotest.fail "Expected Success"
51
+
52
+
let test_error_response () =
53
+
let detail =
54
+
C.Response.error_detail ~code:`Method_not_found ~message:"Not found" ()
55
+
in
56
+
match C.Response.error ~request_id:"req-3" ~error:detail () with
57
+
| C.Response.Error e ->
58
+
Alcotest.(check string) "request_id" "req-3" e.request_id;
59
+
Alcotest.(check int) "code" (-32601) e.error.code;
60
+
Alcotest.(check string) "message" "Not found" e.error.message
61
+
| _ -> Alcotest.fail "Expected Error"
62
+
63
+
let test_error_codes () =
64
+
let codes =
65
+
[
66
+
(`Parse_error, -32700);
67
+
(`Invalid_request, -32600);
68
+
(`Method_not_found, -32601);
69
+
(`Invalid_params, -32602);
70
+
(`Internal_error, -32603);
71
+
(`Custom 42, 42);
72
+
]
73
+
in
74
+
List.iter
75
+
(fun (code, expected) ->
76
+
let detail = C.Response.error_detail ~code ~message:"test" () in
77
+
Alcotest.(check int) "code" expected detail.code)
78
+
codes
79
+
80
+
let test_error_code_of_int () =
81
+
let open C.Response.Error_code in
82
+
Alcotest.(check int) "parse_error" (-32700) (to_int (of_int (-32700)));
83
+
Alcotest.(check int) "invalid_request" (-32600) (to_int (of_int (-32600)));
84
+
Alcotest.(check int) "method_not_found" (-32601) (to_int (of_int (-32601)));
85
+
Alcotest.(check int) "invalid_params" (-32602) (to_int (of_int (-32602)));
86
+
Alcotest.(check int) "internal_error" (-32603) (to_int (of_int (-32603)));
87
+
Alcotest.(check int) "custom 42" 42 (to_int (of_int 42))
88
+
89
+
let test_request_jsont_interrupt () =
90
+
let req = C.Request.interrupt () in
91
+
match Jsont.Json.encode C.Request.jsont req with
92
+
| Ok json -> (
93
+
match Jsont.Json.decode C.Request.jsont json with
94
+
| Ok (C.Request.Interrupt _) -> ()
95
+
| Ok _ -> Alcotest.fail "Wrong variant"
96
+
| Error e -> Alcotest.fail e)
97
+
| Error e -> Alcotest.fail e
98
+
99
+
let test_request_jsont_permission () =
100
+
let input =
101
+
Jsont.Json.object'
102
+
[ Jsont.Json.mem (Jsont.Json.name "cmd") (Jsont.Json.string "ls") ]
103
+
in
104
+
let req = C.Request.permission ~tool_name:"Bash" ~input () in
105
+
match Jsont.Json.encode C.Request.jsont req with
106
+
| Ok json -> (
107
+
match Jsont.Json.decode C.Request.jsont json with
108
+
| Ok (C.Request.Permission p) ->
109
+
Alcotest.(check string) "tool_name" "Bash" p.tool_name
110
+
| Ok _ -> Alcotest.fail "Wrong variant"
111
+
| Error e -> Alcotest.fail e)
112
+
| Error e -> Alcotest.fail e
113
+
114
+
let test_request_jsont_set_model () =
115
+
let req = C.Request.set_model ~model:"claude-haiku-4" () in
116
+
match Jsont.Json.encode C.Request.jsont req with
117
+
| Ok json -> (
118
+
match Jsont.Json.decode C.Request.jsont json with
119
+
| Ok (C.Request.Set_model sm) ->
120
+
Alcotest.(check string) "model" "claude-haiku-4" sm.model
121
+
| Ok _ -> Alcotest.fail "Wrong variant"
122
+
| Error e -> Alcotest.fail e)
123
+
| Error e -> Alcotest.fail e
124
+
125
+
let test_request_jsont_get_server_info () =
126
+
let req = C.Request.get_server_info () in
127
+
match Jsont.Json.encode C.Request.jsont req with
128
+
| Ok json -> (
129
+
match Jsont.Json.decode C.Request.jsont json with
130
+
| Ok (C.Request.Get_server_info _) -> ()
131
+
| Ok _ -> Alcotest.fail "Wrong variant"
132
+
| Error e -> Alcotest.fail e)
133
+
| Error e -> Alcotest.fail e
134
+
135
+
let test_request_jsont_hook_callback () =
136
+
let input = Jsont.Json.object' [] in
137
+
let req = C.Request.hook_callback ~callback_id:"cb-1" ~input () in
138
+
match Jsont.Json.encode C.Request.jsont req with
139
+
| Ok json -> (
140
+
match Jsont.Json.decode C.Request.jsont json with
141
+
| Ok (C.Request.Hook_callback hc) ->
142
+
Alcotest.(check string) "callback_id" "cb-1" hc.callback_id
143
+
| Ok _ -> Alcotest.fail "Wrong variant"
144
+
| Error e -> Alcotest.fail e)
145
+
| Error e -> Alcotest.fail e
146
+
147
+
let test_request_jsont_mcp_message () =
148
+
let message = Jsont.Json.object' [] in
149
+
let req = C.Request.mcp_message ~server_name:"tools" ~message () in
150
+
match Jsont.Json.encode C.Request.jsont req with
151
+
| Ok json -> (
152
+
match Jsont.Json.decode C.Request.jsont json with
153
+
| Ok (C.Request.Mcp_message mm) ->
154
+
Alcotest.(check string) "server_name" "tools" mm.server_name
155
+
| Ok _ -> Alcotest.fail "Wrong variant"
156
+
| Error e -> Alcotest.fail e)
157
+
| Error e -> Alcotest.fail e
158
+
159
+
let test_response_jsont_success () =
160
+
let resp = C.Response.success ~request_id:"r1" () in
161
+
match Jsont.Json.encode C.Response.jsont resp with
162
+
| Ok json -> (
163
+
match Jsont.Json.decode C.Response.jsont json with
164
+
| Ok (C.Response.Success s) ->
165
+
Alcotest.(check string) "request_id" "r1" s.request_id
166
+
| Ok _ -> Alcotest.fail "Wrong variant"
167
+
| Error e -> Alcotest.fail e)
168
+
| Error e -> Alcotest.fail e
169
+
170
+
let test_response_success_data () =
171
+
let data = Jsont.Json.string "result_data" in
172
+
let resp = C.Response.success ~request_id:"r2" ~response:data () in
173
+
match Jsont.Json.encode C.Response.jsont resp with
174
+
| Ok json -> (
175
+
match Jsont.Json.decode C.Response.jsont json with
176
+
| Ok (C.Response.Success s) ->
177
+
Alcotest.(check bool) "has response" true (Option.is_some s.response)
178
+
| Ok _ -> Alcotest.fail "Wrong variant"
179
+
| Error e -> Alcotest.fail e)
180
+
| Error e -> Alcotest.fail e
181
+
182
+
let test_response_jsont_error () =
183
+
let detail =
184
+
C.Response.error_detail ~code:`Internal_error ~message:"oops" ()
185
+
in
186
+
let resp = C.Response.error ~request_id:"r3" ~error:detail () in
187
+
match Jsont.Json.encode C.Response.jsont resp with
188
+
| Ok json -> (
189
+
match Jsont.Json.decode C.Response.jsont json with
190
+
| Ok (C.Response.Error e) ->
191
+
Alcotest.(check string) "request_id" "r3" e.request_id;
192
+
Alcotest.(check int) "code" (-32603) e.error.code;
193
+
Alcotest.(check string) "message" "oops" e.error.message
194
+
| Ok _ -> Alcotest.fail "Wrong variant"
195
+
| Error e -> Alcotest.fail e)
196
+
| Error e -> Alcotest.fail e
197
+
198
+
let test_server_info () =
199
+
let info =
200
+
C.Server_info.create ~version:"2.0.0"
201
+
~capabilities:[ "hooks"; "structured-output" ]
202
+
~commands:[ "run" ] ~output_styles:[ "json" ] ()
203
+
in
204
+
Alcotest.(check string) "version" "2.0.0" (C.Server_info.version info);
205
+
Alcotest.(check (list string))
206
+
"capabilities"
207
+
[ "hooks"; "structured-output" ]
208
+
(C.Server_info.capabilities info)
209
+
210
+
let test_server_info_jsont_roundtrip () =
211
+
let info =
212
+
C.Server_info.create ~version:"1.0.0" ~capabilities:[ "mcp" ] ~commands:[]
213
+
~output_styles:[] ()
214
+
in
215
+
match Jsont.Json.encode C.Server_info.jsont info with
216
+
| Ok json -> (
217
+
match Jsont.Json.decode C.Server_info.jsont json with
218
+
| Ok back ->
219
+
Alcotest.(check string) "version" "1.0.0" (C.Server_info.version back)
220
+
| Error e -> Alcotest.fail e)
221
+
| Error e -> Alcotest.fail e
222
+
223
+
let test_request_envelope () =
224
+
let req = C.Request.interrupt () in
225
+
match C.request ~request_id:"env-1" ~request:req () with
226
+
| C.Request env -> Alcotest.(check string) "request_id" "env-1" env.request_id
227
+
| _ -> Alcotest.fail "Expected Request envelope"
228
+
229
+
let test_response_envelope () =
230
+
let resp = C.Response.success ~request_id:"x" () in
231
+
match C.response ~response:resp () with
232
+
| C.Response env -> (
233
+
match env.response with
234
+
| C.Response.Success _ -> ()
235
+
| _ -> Alcotest.fail "Expected success response")
236
+
| _ -> Alcotest.fail "Expected Response envelope"
237
+
238
+
let test_request_envelope_jsont () =
239
+
let req = C.Request.interrupt () in
240
+
let env : C.control_request =
241
+
{
242
+
type_ = `Control_request;
243
+
request_id = "env-1";
244
+
request = req;
245
+
unknown = Claude.Unknown.empty;
246
+
}
247
+
in
248
+
match Jsont.Json.encode C.control_request_jsont env with
249
+
| Ok json -> (
250
+
match Jsont.Json.decode C.control_request_jsont json with
251
+
| Ok back -> Alcotest.(check string) "request_id" "env-1" back.request_id
252
+
| Error e -> Alcotest.fail e)
253
+
| Error e -> Alcotest.fail e
254
+
255
+
let test_response_envelope_jsont () =
256
+
let resp = C.Response.success ~request_id:"x" () in
257
+
let env : C.control_response =
258
+
{
259
+
type_ = `Control_response;
260
+
response = resp;
261
+
unknown = Claude.Unknown.empty;
262
+
}
263
+
in
264
+
match Jsont.Json.encode C.control_response_jsont env with
265
+
| Ok json -> (
266
+
match Jsont.Json.decode C.control_response_jsont json with
267
+
| Ok back -> (
268
+
match back.response with
269
+
| C.Response.Success _ -> ()
270
+
| _ -> Alcotest.fail "Wrong variant")
271
+
| Error e -> Alcotest.fail e)
272
+
| Error e -> Alcotest.fail e
273
+
274
+
let suite =
275
+
( "control",
276
+
[
277
+
Alcotest.test_case "interrupt request" `Quick test_interrupt_request;
278
+
Alcotest.test_case "permission request" `Quick test_permission_request;
279
+
Alcotest.test_case "initialize request" `Quick test_initialize_request;
280
+
Alcotest.test_case "set_permission_mode request" `Quick
281
+
test_set_permission_mode_request;
282
+
Alcotest.test_case "set_model request" `Quick test_set_model_request;
283
+
Alcotest.test_case "get_server_info request" `Quick
284
+
test_get_server_info_request;
285
+
Alcotest.test_case "success response" `Quick test_success_response;
286
+
Alcotest.test_case "error response" `Quick test_error_response;
287
+
Alcotest.test_case "error codes" `Quick test_error_codes;
288
+
Alcotest.test_case "error code of_int roundtrip" `Quick
289
+
test_error_code_of_int;
290
+
Alcotest.test_case "request jsont interrupt" `Quick
291
+
test_request_jsont_interrupt;
292
+
Alcotest.test_case "request jsont permission" `Quick
293
+
test_request_jsont_permission;
294
+
Alcotest.test_case "request jsont set_model" `Quick
295
+
test_request_jsont_set_model;
296
+
Alcotest.test_case "request jsont get_server_info" `Quick
297
+
test_request_jsont_get_server_info;
298
+
Alcotest.test_case "request jsont hook_callback" `Quick
299
+
test_request_jsont_hook_callback;
300
+
Alcotest.test_case "request jsont mcp_message" `Quick
301
+
test_request_jsont_mcp_message;
302
+
Alcotest.test_case "response jsont success" `Quick
303
+
test_response_jsont_success;
304
+
Alcotest.test_case "response jsont success with data" `Quick
305
+
test_response_success_data;
306
+
Alcotest.test_case "response jsont error" `Quick test_response_jsont_error;
307
+
Alcotest.test_case "server_info" `Quick test_server_info;
308
+
Alcotest.test_case "server_info jsont roundtrip" `Quick
309
+
test_server_info_jsont_roundtrip;
310
+
Alcotest.test_case "request envelope" `Quick test_request_envelope;
311
+
Alcotest.test_case "response envelope" `Quick test_response_envelope;
312
+
Alcotest.test_case "request envelope jsont" `Quick
313
+
test_request_envelope_jsont;
314
+
Alcotest.test_case "response envelope jsont" `Quick
315
+
test_response_envelope_jsont;
316
+
] )
+2
test/test_control.mli
+2
test/test_control.mli
+173
test/test_err.ml
+173
test/test_err.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Err module: error formatting, raisers, and result helpers. *)
7
+
8
+
let test_cli_not_found_format () =
9
+
let err = Claude.Err.Cli_not_found "claude not in PATH" in
10
+
Alcotest.(check string)
11
+
"format" "CLI not found: claude not in PATH" (Claude.Err.to_string err)
12
+
13
+
let test_process_error_format () =
14
+
let err = Claude.Err.Process_error "exit code 1" in
15
+
Alcotest.(check string)
16
+
"format" "Process error: exit code 1" (Claude.Err.to_string err)
17
+
18
+
let test_connection_error_format () =
19
+
let err = Claude.Err.Connection_error "refused" in
20
+
Alcotest.(check string)
21
+
"format" "Connection error: refused" (Claude.Err.to_string err)
22
+
23
+
let test_protocol_error_format () =
24
+
let err = Claude.Err.Protocol_error "bad json" in
25
+
Alcotest.(check string)
26
+
"format" "Protocol error: bad json" (Claude.Err.to_string err)
27
+
28
+
let test_timeout_format () =
29
+
let err = Claude.Err.Timeout "30s elapsed" in
30
+
Alcotest.(check string)
31
+
"format" "Timeout: 30s elapsed" (Claude.Err.to_string err)
32
+
33
+
let test_permission_denied_format () =
34
+
let err =
35
+
Claude.Err.Permission_denied { tool_name = "Bash"; message = "not allowed" }
36
+
in
37
+
Alcotest.(check string)
38
+
"format" "Permission denied for tool 'Bash': not allowed"
39
+
(Claude.Err.to_string err)
40
+
41
+
let test_hook_error_format () =
42
+
let err =
43
+
Claude.Err.Hook_error { callback_id = "cb-1"; message = "hook failed" }
44
+
in
45
+
Alcotest.(check string)
46
+
"format" "Hook error (callback_id=cb-1): hook failed"
47
+
(Claude.Err.to_string err)
48
+
49
+
let test_control_error_format () =
50
+
let err =
51
+
Claude.Err.Control_error { request_id = "req-42"; message = "invalid" }
52
+
in
53
+
Alcotest.(check string)
54
+
"format" "Control error (request_id=req-42): invalid"
55
+
(Claude.Err.to_string err)
56
+
57
+
let test_raise_cli_not_found () =
58
+
match Claude.Err.cli_not_found "missing" with
59
+
| exception Claude.Err.E (Claude.Err.Cli_not_found "missing") -> ()
60
+
| exception _ -> Alcotest.fail "Wrong exception type"
61
+
| _ -> Alcotest.fail "Expected exception"
62
+
63
+
let test_raise_process_error () =
64
+
match Claude.Err.process_error "crash" with
65
+
| exception Claude.Err.E (Claude.Err.Process_error "crash") -> ()
66
+
| exception _ -> Alcotest.fail "Wrong exception type"
67
+
| _ -> Alcotest.fail "Expected exception"
68
+
69
+
let test_raise_connection_error () =
70
+
match Claude.Err.connection_error "reset" with
71
+
| exception Claude.Err.E (Claude.Err.Connection_error "reset") -> ()
72
+
| exception _ -> Alcotest.fail "Wrong exception type"
73
+
| _ -> Alcotest.fail "Expected exception"
74
+
75
+
let test_raise_protocol_error () =
76
+
match Claude.Err.protocol_error "malformed" with
77
+
| exception Claude.Err.E (Claude.Err.Protocol_error "malformed") -> ()
78
+
| exception _ -> Alcotest.fail "Wrong exception type"
79
+
| _ -> Alcotest.fail "Expected exception"
80
+
81
+
let test_raise_timeout () =
82
+
match Claude.Err.timeout "expired" with
83
+
| exception Claude.Err.E (Claude.Err.Timeout "expired") -> ()
84
+
| exception _ -> Alcotest.fail "Wrong exception type"
85
+
| _ -> Alcotest.fail "Expected exception"
86
+
87
+
let test_raise_permission_denied () =
88
+
match Claude.Err.permission_denied ~tool_name:"Edit" ~message:"blocked" with
89
+
| exception
90
+
Claude.Err.E
91
+
(Claude.Err.Permission_denied
92
+
{ tool_name = "Edit"; message = "blocked" }) ->
93
+
()
94
+
| exception _ -> Alcotest.fail "Wrong exception type"
95
+
| _ -> Alcotest.fail "Expected exception"
96
+
97
+
let test_raise_hook_error () =
98
+
match Claude.Err.hook_error ~callback_id:"cb-x" ~message:"fail" with
99
+
| exception
100
+
Claude.Err.E
101
+
(Claude.Err.Hook_error { callback_id = "cb-x"; message = "fail" }) ->
102
+
()
103
+
| exception _ -> Alcotest.fail "Wrong exception type"
104
+
| _ -> Alcotest.fail "Expected exception"
105
+
106
+
let test_raise_control_error () =
107
+
match Claude.Err.control_error ~request_id:"req-1" ~message:"bad" with
108
+
| exception
109
+
Claude.Err.E
110
+
(Claude.Err.Control_error { request_id = "req-1"; message = "bad" }) ->
111
+
()
112
+
| exception _ -> Alcotest.fail "Wrong exception type"
113
+
| _ -> Alcotest.fail "Expected exception"
114
+
115
+
let test_ok_success () =
116
+
let v = Claude.Err.ok ~msg:"test: " (Ok 42) in
117
+
Alcotest.(check int) "ok value" 42 v
118
+
119
+
let test_ok_error () =
120
+
match Claude.Err.ok ~msg:"prefix: " (Error "reason") with
121
+
| exception Claude.Err.E (Claude.Err.Protocol_error msg) ->
122
+
Alcotest.(check bool) "contains prefix" true (String.length msg > 0)
123
+
| exception _ -> Alcotest.fail "Wrong exception type"
124
+
| _ -> Alcotest.fail "Expected exception"
125
+
126
+
let test_ok'_success () =
127
+
let v = Claude.Err.ok' ~msg:"test: " (Ok "hello") in
128
+
Alcotest.(check string) "ok' value" "hello" v
129
+
130
+
let test_ok'_error () =
131
+
match Claude.Err.ok' ~msg:"prefix: " (Error "reason") with
132
+
| exception Claude.Err.E (Claude.Err.Protocol_error _) -> ()
133
+
| exception _ -> Alcotest.fail "Wrong exception type"
134
+
| _ -> Alcotest.fail "Expected exception"
135
+
136
+
let test_pp_output () =
137
+
let err = Claude.Err.Timeout "10s" in
138
+
let buf = Buffer.create 32 in
139
+
let ppf = Format.formatter_of_buffer buf in
140
+
Claude.Err.pp ppf err;
141
+
Format.pp_print_flush ppf ();
142
+
Alcotest.(check string) "pp output" "Timeout: 10s" (Buffer.contents buf)
143
+
144
+
let suite =
145
+
( "err",
146
+
[
147
+
Alcotest.test_case "Cli_not_found format" `Quick test_cli_not_found_format;
148
+
Alcotest.test_case "Process_error format" `Quick test_process_error_format;
149
+
Alcotest.test_case "Connection_error format" `Quick
150
+
test_connection_error_format;
151
+
Alcotest.test_case "Protocol_error format" `Quick
152
+
test_protocol_error_format;
153
+
Alcotest.test_case "Timeout format" `Quick test_timeout_format;
154
+
Alcotest.test_case "Permission_denied format" `Quick
155
+
test_permission_denied_format;
156
+
Alcotest.test_case "Hook_error format" `Quick test_hook_error_format;
157
+
Alcotest.test_case "Control_error format" `Quick test_control_error_format;
158
+
Alcotest.test_case "raise cli_not_found" `Quick test_raise_cli_not_found;
159
+
Alcotest.test_case "raise process_error" `Quick test_raise_process_error;
160
+
Alcotest.test_case "raise connection_error" `Quick
161
+
test_raise_connection_error;
162
+
Alcotest.test_case "raise protocol_error" `Quick test_raise_protocol_error;
163
+
Alcotest.test_case "raise timeout" `Quick test_raise_timeout;
164
+
Alcotest.test_case "raise permission_denied" `Quick
165
+
test_raise_permission_denied;
166
+
Alcotest.test_case "raise hook_error" `Quick test_raise_hook_error;
167
+
Alcotest.test_case "raise control_error" `Quick test_raise_control_error;
168
+
Alcotest.test_case "ok success" `Quick test_ok_success;
169
+
Alcotest.test_case "ok error" `Quick test_ok_error;
170
+
Alcotest.test_case "ok' success" `Quick test_ok'_success;
171
+
Alcotest.test_case "ok' error" `Quick test_ok'_error;
172
+
Alcotest.test_case "pp output" `Quick test_pp_output;
173
+
] )
+2
test/test_err.mli
+2
test/test_err.mli
+109
test/test_handler.ml
+109
test/test_handler.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Handler module: default handler, dispatch. *)
7
+
8
+
module R = Claude.Response
9
+
module M = Claude.Message
10
+
module CB = Claude.Content_block
11
+
module H = Claude.Handler
12
+
13
+
(* Helpers to create response events *)
14
+
let mk_text_response s =
15
+
let block = CB.Text.create s in
16
+
R.Text (R.Text.of_block block)
17
+
18
+
let mk_init_response () =
19
+
let sys = M.System.init ~session_id:"s1" () in
20
+
match R.Init.of_system sys with
21
+
| Some init -> R.Init init
22
+
| None -> failwith "failed to create init response"
23
+
24
+
let mk_error_response () =
25
+
let sys = M.System.error ~error:"test error" in
26
+
match R.Error.of_system sys with
27
+
| Some err -> R.Error err
28
+
| None -> failwith "failed to create error response"
29
+
30
+
let mk_complete_response () =
31
+
let result =
32
+
M.Result.create ~subtype:"success" ~duration_ms:100 ~duration_api_ms:50
33
+
~is_error:false ~num_turns:1 ~session_id:"s1" ()
34
+
in
35
+
R.Complete (R.Complete.of_result result)
36
+
37
+
(* Default handler tests - verify all methods are callable without error *)
38
+
let test_default_handler_text () =
39
+
let handler = new H.default in
40
+
let text = mk_text_response "hello" in
41
+
H.dispatch handler text
42
+
43
+
let test_default_handler_init () =
44
+
let handler = new H.default in
45
+
let init = mk_init_response () in
46
+
H.dispatch handler init
47
+
48
+
let test_default_handler_error () =
49
+
let handler = new H.default in
50
+
let err = mk_error_response () in
51
+
H.dispatch handler err
52
+
53
+
let test_default_handler_complete () =
54
+
let handler = new H.default in
55
+
let complete = mk_complete_response () in
56
+
H.dispatch handler complete
57
+
58
+
(* Custom handler that records calls *)
59
+
let test_custom_handler_dispatch () =
60
+
let calls = ref [] in
61
+
let handler =
62
+
object
63
+
inherit H.default
64
+
method! on_text _t = calls := "text" :: !calls
65
+
method! on_complete _c = calls := "complete" :: !calls
66
+
end
67
+
in
68
+
H.dispatch handler (mk_text_response "t");
69
+
H.dispatch handler (mk_complete_response ());
70
+
Alcotest.(check (list string)) "calls" [ "complete"; "text" ] !calls
71
+
72
+
(* dispatch_all *)
73
+
let test_dispatch_all () =
74
+
let count = ref 0 in
75
+
let handler =
76
+
object
77
+
inherit H.default
78
+
method! on_text _t = incr count
79
+
method! on_complete _c = incr count
80
+
end
81
+
in
82
+
H.dispatch_all handler [ mk_text_response "a"; mk_complete_response () ];
83
+
Alcotest.(check int) "dispatch_all count" 2 !count
84
+
85
+
let test_dispatch_all_empty () =
86
+
let count = ref 0 in
87
+
let handler =
88
+
object
89
+
inherit H.default
90
+
method! on_text _t = incr count
91
+
end
92
+
in
93
+
H.dispatch_all handler [];
94
+
Alcotest.(check int) "empty dispatch" 0 !count
95
+
96
+
let suite =
97
+
( "handler",
98
+
[
99
+
Alcotest.test_case "default handler text" `Quick test_default_handler_text;
100
+
Alcotest.test_case "default handler init" `Quick test_default_handler_init;
101
+
Alcotest.test_case "default handler error" `Quick
102
+
test_default_handler_error;
103
+
Alcotest.test_case "default handler complete" `Quick
104
+
test_default_handler_complete;
105
+
Alcotest.test_case "custom handler dispatch" `Quick
106
+
test_custom_handler_dispatch;
107
+
Alcotest.test_case "dispatch_all" `Quick test_dispatch_all;
108
+
Alcotest.test_case "dispatch_all empty" `Quick test_dispatch_all_empty;
109
+
] )
+2
test/test_handler.mli
+2
test/test_handler.mli
+172
test/test_hooks.ml
+172
test/test_hooks.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Hooks module: response builders, configuration, callback wiring.
7
+
*)
8
+
9
+
module H = Claude.Hooks
10
+
11
+
(* Pre_tool_use response builders *)
12
+
let test_pre_tool_use_allow () =
13
+
let out = H.Pre_tool_use.allow () in
14
+
Alcotest.(check (option string)) "no reason" None out.reason;
15
+
Alcotest.(check bool) "decision is Some" true (Option.is_some out.decision);
16
+
match out.decision with
17
+
| Some H.Pre_tool_use.Allow -> ()
18
+
| _ -> Alcotest.fail "Expected Allow"
19
+
20
+
let test_pre_tool_allow_reason () =
21
+
let out = H.Pre_tool_use.allow ~reason:"safe command" () in
22
+
Alcotest.(check (option string)) "reason" (Some "safe command") out.reason
23
+
24
+
let test_pre_tool_allow_updated () =
25
+
let input =
26
+
Claude.Tool_input.empty |> Claude.Tool_input.add_string "cmd" "safe-ls"
27
+
in
28
+
let out = H.Pre_tool_use.allow ~updated_input:input () in
29
+
match out.updated_input with
30
+
| Some inp ->
31
+
Alcotest.(check (option string))
32
+
"cmd" (Some "safe-ls")
33
+
(Claude.Tool_input.string inp "cmd")
34
+
| None -> Alcotest.fail "Expected updated_input"
35
+
36
+
let test_pre_tool_use_deny () =
37
+
let out = H.Pre_tool_use.deny ~reason:"dangerous" () in
38
+
(match out.decision with
39
+
| Some H.Pre_tool_use.Deny -> ()
40
+
| _ -> Alcotest.fail "Expected Deny");
41
+
Alcotest.(check (option string)) "reason" (Some "dangerous") out.reason
42
+
43
+
let test_pre_tool_use_ask () =
44
+
let out = H.Pre_tool_use.ask () in
45
+
match out.decision with
46
+
| Some H.Pre_tool_use.Ask -> ()
47
+
| _ -> Alcotest.fail "Expected Ask"
48
+
49
+
let test_pre_tool_use_continue () =
50
+
let out = H.Pre_tool_use.continue () in
51
+
Alcotest.(check bool) "no decision" true (Option.is_none out.decision);
52
+
Alcotest.(check (option string)) "no reason" None out.reason;
53
+
Alcotest.(check bool) "no input" true (Option.is_none out.updated_input)
54
+
55
+
(* Post_tool_use response builders *)
56
+
let test_post_tool_use_continue () =
57
+
let out = H.Post_tool_use.continue () in
58
+
Alcotest.(check bool) "not block" false out.block;
59
+
Alcotest.(check (option string)) "no reason" None out.reason
60
+
61
+
let test_post_tool_continue_ctx () =
62
+
let out = H.Post_tool_use.continue ~additional_context:"note" () in
63
+
Alcotest.(check bool) "not block" false out.block;
64
+
Alcotest.(check (option string))
65
+
"context" (Some "note") out.additional_context
66
+
67
+
let test_post_tool_use_block () =
68
+
let out = H.Post_tool_use.block ~reason:"bad output" () in
69
+
Alcotest.(check bool) "block" true out.block;
70
+
Alcotest.(check (option string)) "reason" (Some "bad output") out.reason
71
+
72
+
(* User_prompt_submit response builders *)
73
+
let test_user_prompt_submit_continue () =
74
+
let out = H.User_prompt_submit.continue () in
75
+
Alcotest.(check bool) "not block" false out.block
76
+
77
+
let test_user_prompt_submit_block () =
78
+
let out = H.User_prompt_submit.block ~reason:"too long" () in
79
+
Alcotest.(check bool) "block" true out.block;
80
+
Alcotest.(check (option string)) "reason" (Some "too long") out.reason
81
+
82
+
(* Stop response builders *)
83
+
let test_stop_continue () =
84
+
let out = H.Stop.continue () in
85
+
Alcotest.(check bool) "not block" false out.block
86
+
87
+
let test_stop_block () =
88
+
let out = H.Stop.block ~reason:"keep going" () in
89
+
Alcotest.(check bool) "block" true out.block;
90
+
Alcotest.(check (option string)) "reason" (Some "keep going") out.reason
91
+
92
+
(* Subagent_stop response builders *)
93
+
let test_subagent_stop_continue () =
94
+
let out = H.Subagent_stop.continue () in
95
+
Alcotest.(check bool) "not block" false out.block
96
+
97
+
let test_subagent_stop_block () =
98
+
let out = H.Subagent_stop.block () in
99
+
Alcotest.(check bool) "block" true out.block
100
+
101
+
(* Hook configuration *)
102
+
let test_empty_config () =
103
+
let config = H.empty in
104
+
let cbs = H.callbacks config in
105
+
Alcotest.(check int) "no callbacks" 0 (List.length cbs)
106
+
107
+
let test_on_pre_tool_use () =
108
+
let config =
109
+
H.empty |> H.on_pre_tool_use (fun _input -> H.Pre_tool_use.continue ())
110
+
in
111
+
let cbs = H.callbacks config in
112
+
Alcotest.(check int) "1 event group" 1 (List.length cbs)
113
+
114
+
let test_on_post_tool_use () =
115
+
let config =
116
+
H.empty |> H.on_post_tool_use (fun _input -> H.Post_tool_use.continue ())
117
+
in
118
+
let cbs = H.callbacks config in
119
+
Alcotest.(check int) "1 event group" 1 (List.length cbs)
120
+
121
+
let test_multiple_hooks () =
122
+
let config =
123
+
H.empty
124
+
|> H.on_pre_tool_use (fun _ -> H.Pre_tool_use.continue ())
125
+
|> H.on_post_tool_use (fun _ -> H.Post_tool_use.continue ())
126
+
|> H.on_stop (fun _ -> H.Stop.continue ())
127
+
in
128
+
let cbs = H.callbacks config in
129
+
Alcotest.(check int) "3 event groups" 3 (List.length cbs)
130
+
131
+
let test_pp_does_not_crash () =
132
+
let config =
133
+
H.empty |> H.on_pre_tool_use (fun _ -> H.Pre_tool_use.continue ())
134
+
in
135
+
let buf = Buffer.create 32 in
136
+
let ppf = Format.formatter_of_buffer buf in
137
+
H.pp ppf config;
138
+
Format.pp_print_flush ppf ();
139
+
Alcotest.(check bool) "pp output" true (Buffer.contents buf <> "")
140
+
141
+
let suite =
142
+
( "hooks",
143
+
[
144
+
Alcotest.test_case "pre_tool_use allow" `Quick test_pre_tool_use_allow;
145
+
Alcotest.test_case "pre_tool_use allow with reason" `Quick
146
+
test_pre_tool_allow_reason;
147
+
Alcotest.test_case "pre_tool_use allow with updated input" `Quick
148
+
test_pre_tool_allow_updated;
149
+
Alcotest.test_case "pre_tool_use deny" `Quick test_pre_tool_use_deny;
150
+
Alcotest.test_case "pre_tool_use ask" `Quick test_pre_tool_use_ask;
151
+
Alcotest.test_case "pre_tool_use continue" `Quick
152
+
test_pre_tool_use_continue;
153
+
Alcotest.test_case "post_tool_use continue" `Quick
154
+
test_post_tool_use_continue;
155
+
Alcotest.test_case "post_tool_use continue with context" `Quick
156
+
test_post_tool_continue_ctx;
157
+
Alcotest.test_case "post_tool_use block" `Quick test_post_tool_use_block;
158
+
Alcotest.test_case "user_prompt_submit continue" `Quick
159
+
test_user_prompt_submit_continue;
160
+
Alcotest.test_case "user_prompt_submit block" `Quick
161
+
test_user_prompt_submit_block;
162
+
Alcotest.test_case "stop continue" `Quick test_stop_continue;
163
+
Alcotest.test_case "stop block" `Quick test_stop_block;
164
+
Alcotest.test_case "subagent_stop continue" `Quick
165
+
test_subagent_stop_continue;
166
+
Alcotest.test_case "subagent_stop block" `Quick test_subagent_stop_block;
167
+
Alcotest.test_case "empty config" `Quick test_empty_config;
168
+
Alcotest.test_case "on_pre_tool_use" `Quick test_on_pre_tool_use;
169
+
Alcotest.test_case "on_post_tool_use" `Quick test_on_post_tool_use;
170
+
Alcotest.test_case "multiple hooks" `Quick test_multiple_hooks;
171
+
Alcotest.test_case "pp does not crash" `Quick test_pp_does_not_crash;
172
+
] )
+2
test/test_hooks.mli
+2
test/test_hooks.mli
+113
test/test_incoming.ml
+113
test/test_incoming.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let decode_incoming json_str =
7
+
Jsont_bytesrw.decode_string' Claude.Incoming.jsont json_str
8
+
9
+
let test_decode_system_init () =
10
+
let json =
11
+
{|{"type":"system","subtype":"init","session_id":"s1","model":"claude-sonnet-4","cwd":"/tmp"}|}
12
+
in
13
+
match decode_incoming json with
14
+
| Ok (Claude.Incoming.Message (Claude.Message.System sys)) ->
15
+
Alcotest.(check (option string))
16
+
"session_id" (Some "s1")
17
+
(Claude.Message.System.session_id sys);
18
+
Alcotest.(check (option string))
19
+
"model" (Some "claude-sonnet-4")
20
+
(Claude.Message.System.model sys);
21
+
Alcotest.(check (option string))
22
+
"cwd" (Some "/tmp")
23
+
(Claude.Message.System.cwd sys)
24
+
| Ok _ -> Alcotest.fail "Wrong message type"
25
+
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
26
+
27
+
let test_decode_system_error () =
28
+
let json =
29
+
{|{"type":"system","subtype":"error","error":"something went wrong"}|}
30
+
in
31
+
match decode_incoming json with
32
+
| Ok
33
+
(Claude.Incoming.Message
34
+
(Claude.Message.System (Claude.Message.System.Error e))) ->
35
+
Alcotest.(check string) "error" "something went wrong" e.error
36
+
| Ok _ -> Alcotest.fail "Wrong message type"
37
+
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
38
+
39
+
let test_decode_result () =
40
+
let json =
41
+
{|{"type":"result","subtype":"success","duration_ms":1000,"duration_api_ms":800,"is_error":false,"num_turns":3,"session_id":"sess-42","total_cost_usd":0.05}|}
42
+
in
43
+
match decode_incoming json with
44
+
| Ok (Claude.Incoming.Message (Claude.Message.Result r)) ->
45
+
Alcotest.(check int)
46
+
"duration_ms" 1000
47
+
(Claude.Message.Result.duration_ms r);
48
+
Alcotest.(check int) "num_turns" 3 (Claude.Message.Result.num_turns r);
49
+
Alcotest.(check string)
50
+
"session_id" "sess-42"
51
+
(Claude.Message.Result.session_id r);
52
+
Alcotest.(check bool)
53
+
"not is_error" false
54
+
(Claude.Message.Result.is_error r)
55
+
| Ok _ -> Alcotest.fail "Wrong message type"
56
+
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
57
+
58
+
let test_decode_assistant_tools () =
59
+
let json =
60
+
{|{"type":"assistant","message":{"model":"claude-sonnet-4","content":[{"type":"tool_use","id":"tu-1","name":"Bash","input":{"command":"ls"}}]}}|}
61
+
in
62
+
match decode_incoming json with
63
+
| Ok (Claude.Incoming.Message (Claude.Message.Assistant msg)) ->
64
+
let content = Claude.Message.Assistant.content msg in
65
+
let has_tool_use =
66
+
List.exists
67
+
(function Claude.Content_block.Tool_use _ -> true | _ -> false)
68
+
content
69
+
in
70
+
Alcotest.(check bool) "has_tool_use" true has_tool_use
71
+
| Ok _ -> Alcotest.fail "Wrong message type"
72
+
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
73
+
74
+
let test_decode_control_response () =
75
+
let json =
76
+
{|{"type":"control_response","response":{"subtype":"success","request_id":"req-1"}}|}
77
+
in
78
+
match decode_incoming json with
79
+
| Ok (Claude.Incoming.Control_response _) -> ()
80
+
| Ok _ -> Alcotest.fail "Wrong message type, expected Control_response"
81
+
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
82
+
83
+
let test_decode_user_message () =
84
+
let json = {|{"type":"user","message":{"content":"Hi"}}|} in
85
+
match decode_incoming json with
86
+
| Ok (Claude.Incoming.Message (Claude.Message.User _)) -> ()
87
+
| Ok _ -> Alcotest.fail "Expected user message"
88
+
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
89
+
90
+
let test_pp_does_not_crash () =
91
+
let json = {|{"type":"user","message":{"content":"Hi"}}|} in
92
+
match decode_incoming json with
93
+
| Ok incoming ->
94
+
let buf = Buffer.create 64 in
95
+
let ppf = Format.formatter_of_buffer buf in
96
+
Claude.Incoming.pp ppf incoming;
97
+
Format.pp_print_flush ppf ();
98
+
Alcotest.(check bool) "pp output" true (Buffer.contents buf <> "")
99
+
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
100
+
101
+
let suite =
102
+
( "incoming",
103
+
[
104
+
Alcotest.test_case "decode system init" `Quick test_decode_system_init;
105
+
Alcotest.test_case "decode system error" `Quick test_decode_system_error;
106
+
Alcotest.test_case "decode result" `Quick test_decode_result;
107
+
Alcotest.test_case "decode assistant with tool_use" `Quick
108
+
test_decode_assistant_tools;
109
+
Alcotest.test_case "decode control_response" `Quick
110
+
test_decode_control_response;
111
+
Alcotest.test_case "decode user message" `Quick test_decode_user_message;
112
+
Alcotest.test_case "pp does not crash" `Quick test_pp_does_not_crash;
113
+
] )
+2
test/test_incoming.mli
+2
test/test_incoming.mli
+177
test/test_mcp_server.ml
+177
test/test_mcp_server.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Mcp_server module: creation, accessors, request handling.
7
+
Complements the tests in test_claude.ml with additional edge cases. *)
8
+
9
+
module J = Jsont.Json
10
+
11
+
let mk_tool name =
12
+
Claude.Tool.v ~name ~description:("Tool: " ^ name)
13
+
~input_schema:(Claude.Tool.schema_object [] ~required:[]) ~handler:(fun _ ->
14
+
Ok (Claude.Tool.text_result ("ok from " ^ name)))
15
+
16
+
let test_default_version () =
17
+
let server = Claude.Mcp_server.v ~name:"test" ~tools:[] () in
18
+
Alcotest.(check string)
19
+
"default version" "1.0.0"
20
+
(Claude.Mcp_server.version server)
21
+
22
+
let test_custom_version () =
23
+
let server = Claude.Mcp_server.v ~name:"test" ~version:"3.0.0" ~tools:[] () in
24
+
Alcotest.(check string)
25
+
"custom version" "3.0.0"
26
+
(Claude.Mcp_server.version server)
27
+
28
+
let test_name () =
29
+
let server = Claude.Mcp_server.v ~name:"my-server" ~tools:[] () in
30
+
Alcotest.(check string) "name" "my-server" (Claude.Mcp_server.name server)
31
+
32
+
let test_tools_list () =
33
+
let t1 = mk_tool "a" in
34
+
let t2 = mk_tool "b" in
35
+
let server = Claude.Mcp_server.v ~name:"s" ~tools:[ t1; t2 ] () in
36
+
Alcotest.(check int)
37
+
"tool count" 2
38
+
(List.length (Claude.Mcp_server.tools server))
39
+
40
+
let test_handle_initialize () =
41
+
let server = Claude.Mcp_server.v ~name:"init-test" ~tools:[] () in
42
+
let req =
43
+
J.object'
44
+
[
45
+
J.mem (J.name "jsonrpc") (J.string "2.0");
46
+
J.mem (J.name "id") (J.number 1.0);
47
+
J.mem (J.name "method") (J.string "initialize");
48
+
J.mem (J.name "params") (J.object' []);
49
+
]
50
+
in
51
+
let resp = Claude.Mcp_server.handle_json_message server req in
52
+
match resp with
53
+
| Jsont.Object (mems, _) ->
54
+
Alcotest.(check bool)
55
+
"has result" true
56
+
(List.exists (fun ((k, _), _) -> k = "result") mems)
57
+
| _ -> Alcotest.fail "Expected object response"
58
+
59
+
let test_handle_tools_list_empty () =
60
+
let server = Claude.Mcp_server.v ~name:"empty" ~tools:[] () in
61
+
let req =
62
+
J.object'
63
+
[
64
+
J.mem (J.name "jsonrpc") (J.string "2.0");
65
+
J.mem (J.name "id") (J.number 1.0);
66
+
J.mem (J.name "method") (J.string "tools/list");
67
+
J.mem (J.name "params") (J.object' []);
68
+
]
69
+
in
70
+
let resp = Claude.Mcp_server.handle_json_message server req in
71
+
match resp with
72
+
| Jsont.Object (mems, _) -> (
73
+
match List.find_opt (fun ((k, _), _) -> k = "result") mems with
74
+
| Some (_, Jsont.Object (result_mems, _)) -> (
75
+
match List.find_opt (fun ((k, _), _) -> k = "tools") result_mems with
76
+
| Some (_, Jsont.Array (tools, _)) ->
77
+
Alcotest.(check int) "0 tools" 0 (List.length tools)
78
+
| _ -> Alcotest.fail "Missing tools")
79
+
| _ -> Alcotest.fail "Missing result")
80
+
| _ -> Alcotest.fail "Expected object"
81
+
82
+
let test_handle_tools_call_success () =
83
+
let tool =
84
+
Claude.Tool.v ~name:"add" ~description:"Add two numbers"
85
+
~input_schema:
86
+
(Claude.Tool.schema_object
87
+
[ ("a", Claude.Tool.schema_int); ("b", Claude.Tool.schema_int) ]
88
+
~required:[ "a"; "b" ])
89
+
~handler:(fun args ->
90
+
match
91
+
(Claude.Tool_input.int args "a", Claude.Tool_input.int args "b")
92
+
with
93
+
| Some a, Some b -> Ok (Claude.Tool.text_result (string_of_int (a + b)))
94
+
| _ -> Error "Missing parameters")
95
+
in
96
+
let server = Claude.Mcp_server.v ~name:"math" ~tools:[ tool ] () in
97
+
let req =
98
+
J.object'
99
+
[
100
+
J.mem (J.name "jsonrpc") (J.string "2.0");
101
+
J.mem (J.name "id") (J.number 1.0);
102
+
J.mem (J.name "method") (J.string "tools/call");
103
+
J.mem (J.name "params")
104
+
(J.object'
105
+
[
106
+
J.mem (J.name "name") (J.string "add");
107
+
J.mem (J.name "arguments")
108
+
(J.object'
109
+
[
110
+
J.mem (J.name "a") (J.number 3.0);
111
+
J.mem (J.name "b") (J.number 7.0);
112
+
]);
113
+
]);
114
+
]
115
+
in
116
+
let resp = Claude.Mcp_server.handle_json_message server req in
117
+
let resp_str =
118
+
match Jsont_bytesrw.encode_string' Jsont.json resp with
119
+
| Ok s -> s
120
+
| Error _ -> ""
121
+
in
122
+
(* Check the response contains "10" *)
123
+
Alcotest.(check bool)
124
+
"contains 10" true
125
+
(let rec check i =
126
+
if i + 2 > String.length resp_str then false
127
+
else if String.sub resp_str i 2 = "10" then true
128
+
else check (i + 1)
129
+
in
130
+
check 0)
131
+
132
+
let test_handle_unknown_method () =
133
+
let server = Claude.Mcp_server.v ~name:"s" ~tools:[] () in
134
+
let req =
135
+
J.object'
136
+
[
137
+
J.mem (J.name "jsonrpc") (J.string "2.0");
138
+
J.mem (J.name "id") (J.number 1.0);
139
+
J.mem (J.name "method") (J.string "completely/unknown");
140
+
J.mem (J.name "params") (J.object' []);
141
+
]
142
+
in
143
+
let resp = Claude.Mcp_server.handle_json_message server req in
144
+
match resp with
145
+
| Jsont.Object (mems, _) ->
146
+
Alcotest.(check bool)
147
+
"has error" true
148
+
(List.exists (fun ((k, _), _) -> k = "error") mems)
149
+
| _ -> Alcotest.fail "Expected object"
150
+
151
+
let test_handle_request_directly () =
152
+
let tool = mk_tool "echo" in
153
+
let server = Claude.Mcp_server.v ~name:"s" ~tools:[ tool ] () in
154
+
let id = J.number 99.0 in
155
+
let resp =
156
+
Claude.Mcp_server.handle_request server ~method_:"tools/list"
157
+
~params:(J.object' []) ~id
158
+
in
159
+
match resp with Jsont.Object _ -> () | _ -> Alcotest.fail "Expected object"
160
+
161
+
let suite =
162
+
( "mcp_server",
163
+
[
164
+
Alcotest.test_case "default version" `Quick test_default_version;
165
+
Alcotest.test_case "custom version" `Quick test_custom_version;
166
+
Alcotest.test_case "name" `Quick test_name;
167
+
Alcotest.test_case "tools list accessor" `Quick test_tools_list;
168
+
Alcotest.test_case "handle initialize" `Quick test_handle_initialize;
169
+
Alcotest.test_case "handle tools/list empty" `Quick
170
+
test_handle_tools_list_empty;
171
+
Alcotest.test_case "handle tools/call success" `Quick
172
+
test_handle_tools_call_success;
173
+
Alcotest.test_case "handle unknown method" `Quick
174
+
test_handle_unknown_method;
175
+
Alcotest.test_case "handle_request directly" `Quick
176
+
test_handle_request_directly;
177
+
] )
+2
test/test_mcp_server.mli
+2
test/test_mcp_server.mli
+177
test/test_message.ml
+177
test/test_message.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Message module: constructors, type predicates, extractors. *)
7
+
8
+
module M = Claude.Message
9
+
module CB = Claude.Content_block
10
+
11
+
(* User message tests *)
12
+
let test_user_of_string () =
13
+
let u = M.User.of_string "hello" in
14
+
Alcotest.(check (option string)) "as_text" (Some "hello") (M.User.as_text u)
15
+
16
+
let test_user_of_blocks () =
17
+
let blocks = [ CB.text "line1"; CB.text "line2" ] in
18
+
let u = M.User.of_blocks blocks in
19
+
Alcotest.(check (option string)) "as_text is None" None (M.User.as_text u);
20
+
Alcotest.(check int) "block count" 2 (List.length (M.User.blocks u))
21
+
22
+
let test_user_string_as_blocks () =
23
+
let u = M.User.of_string "txt" in
24
+
let blocks = M.User.blocks u in
25
+
Alcotest.(check int) "1 block" 1 (List.length blocks);
26
+
match List.hd blocks with
27
+
| CB.Text t -> Alcotest.(check string) "text" "txt" (CB.Text.text t)
28
+
| _ -> Alcotest.fail "Expected Text block"
29
+
30
+
let test_user_with_tool_result () =
31
+
let content = Jsont.Json.string "result data" in
32
+
let u =
33
+
M.User.with_tool_result ~tool_use_id:"tu-1" ~content ~is_error:false ()
34
+
in
35
+
(* User messages with tool results should have blocks *)
36
+
let blocks = M.User.blocks u in
37
+
Alcotest.(check bool) "has blocks" true (List.length blocks > 0)
38
+
39
+
let mk_assistant_msg ?(error = None) content_blocks model =
40
+
M.Assistant.create ~content:content_blocks ~model ?error ()
41
+
42
+
let test_assistant_content () =
43
+
let msg = mk_assistant_msg [ CB.text "Hi there" ] "claude-sonnet-4" in
44
+
let content = M.Assistant.content msg in
45
+
Alcotest.(check int) "1 block" 1 (List.length content);
46
+
match List.hd content with
47
+
| CB.Text t -> Alcotest.(check string) "text" "Hi there" (CB.Text.text t)
48
+
| _ -> Alcotest.fail "Expected Text block"
49
+
50
+
let test_assistant_model () =
51
+
let msg = mk_assistant_msg [] "claude-opus-4" in
52
+
Alcotest.(check string) "model" "claude-opus-4" (M.Assistant.model msg)
53
+
54
+
let test_assistant_text_blocks () =
55
+
let msg = mk_assistant_msg [ CB.text "a"; CB.text "b" ] "claude-sonnet-4" in
56
+
Alcotest.(check (list string))
57
+
"text blocks" [ "a"; "b" ]
58
+
(M.Assistant.text_blocks msg)
59
+
60
+
let test_assistant_combined_text () =
61
+
let msg =
62
+
mk_assistant_msg [ CB.text "hello"; CB.text "world" ] "claude-sonnet-4"
63
+
in
64
+
Alcotest.(check string)
65
+
"combined" "hello\nworld"
66
+
(M.Assistant.combined_text msg)
67
+
68
+
let test_assistant_has_tool_use () =
69
+
let input = Claude.Tool_input.empty in
70
+
let msg =
71
+
mk_assistant_msg
72
+
[ CB.tool_use ~id:"tu-1" ~name:"Bash" ~input ]
73
+
"claude-sonnet-4"
74
+
in
75
+
Alcotest.(check bool) "has_tool_use" true (M.Assistant.has_tool_use msg)
76
+
77
+
let test_assistant_no_tool_use () =
78
+
let msg = mk_assistant_msg [ CB.text "no tools" ] "claude-sonnet-4" in
79
+
Alcotest.(check bool) "no tool_use" false (M.Assistant.has_tool_use msg)
80
+
81
+
let test_assistant_error () =
82
+
let msg =
83
+
mk_assistant_msg ~error:(Some `Rate_limit)
84
+
[ CB.text "error" ]
85
+
"claude-sonnet-4"
86
+
in
87
+
match M.Assistant.error msg with
88
+
| Some `Rate_limit -> ()
89
+
| _ -> Alcotest.fail "Expected Rate_limit error"
90
+
91
+
let mk_system_init ?session_id ?model ?cwd () =
92
+
M.System.init ?session_id ?model ?cwd ()
93
+
94
+
let mk_system_error err = M.System.error ~error:err
95
+
96
+
let test_system_init () =
97
+
let sys = mk_system_init ~session_id:"sess-1" ~model:"claude-sonnet-4" () in
98
+
Alcotest.(check bool) "is_init" true (M.System.is_init sys);
99
+
Alcotest.(check bool) "not is_error" false (M.System.is_error sys);
100
+
Alcotest.(check (option string))
101
+
"session_id" (Some "sess-1") (M.System.session_id sys);
102
+
Alcotest.(check (option string))
103
+
"model" (Some "claude-sonnet-4") (M.System.model sys)
104
+
105
+
let test_system_error () =
106
+
let sys = mk_system_error "something broke" in
107
+
Alcotest.(check bool) "is_error" true (M.System.is_error sys);
108
+
Alcotest.(check bool) "not is_init" false (M.System.is_init sys);
109
+
Alcotest.(check (option string))
110
+
"error_message" (Some "something broke")
111
+
(M.System.error_message sys)
112
+
113
+
(* Message union type tests *)
114
+
let test_is_user () =
115
+
let msg = M.user_string "hi" in
116
+
Alcotest.(check bool) "is_user" true (M.is_user msg);
117
+
Alcotest.(check bool) "not is_assistant" false (M.is_assistant msg);
118
+
Alcotest.(check bool) "not is_system" false (M.is_system msg);
119
+
Alcotest.(check bool) "not is_result" false (M.is_result msg)
120
+
121
+
let test_extract_text_from_user () =
122
+
let msg = M.user_string "extract me" in
123
+
Alcotest.(check (option string))
124
+
"extract_text" (Some "extract me") (M.extract_text msg)
125
+
126
+
let test_extract_text_from_assistant () =
127
+
let asst = mk_assistant_msg [ CB.text "response" ] "claude-sonnet-4" in
128
+
let msg = M.Assistant asst in
129
+
Alcotest.(check (option string))
130
+
"extract_text" (Some "response") (M.extract_text msg)
131
+
132
+
let test_extract_tools_user () =
133
+
let msg = M.user_string "no tools" in
134
+
Alcotest.(check (list string))
135
+
"no tool_uses" []
136
+
(List.map CB.Tool_use.name (M.extract_tool_uses msg))
137
+
138
+
let test_session_id_from_system () =
139
+
let sys = mk_system_init ~session_id:"sess-x" () in
140
+
let msg = M.System sys in
141
+
Alcotest.(check (option string))
142
+
"session_id" (Some "sess-x") (M.session_id msg)
143
+
144
+
let test_session_id_from_user () =
145
+
let msg = M.user_string "no session" in
146
+
Alcotest.(check (option string)) "no session_id" None (M.session_id msg)
147
+
148
+
let suite =
149
+
( "message",
150
+
[
151
+
Alcotest.test_case "user of_string" `Quick test_user_of_string;
152
+
Alcotest.test_case "user of_blocks" `Quick test_user_of_blocks;
153
+
Alcotest.test_case "user string as blocks" `Quick
154
+
test_user_string_as_blocks;
155
+
Alcotest.test_case "user with tool result" `Quick
156
+
test_user_with_tool_result;
157
+
Alcotest.test_case "assistant content" `Quick test_assistant_content;
158
+
Alcotest.test_case "assistant model" `Quick test_assistant_model;
159
+
Alcotest.test_case "assistant text_blocks" `Quick
160
+
test_assistant_text_blocks;
161
+
Alcotest.test_case "assistant combined_text" `Quick
162
+
test_assistant_combined_text;
163
+
Alcotest.test_case "assistant has_tool_use" `Quick
164
+
test_assistant_has_tool_use;
165
+
Alcotest.test_case "assistant no tool_use" `Quick
166
+
test_assistant_no_tool_use;
167
+
Alcotest.test_case "assistant error" `Quick test_assistant_error;
168
+
Alcotest.test_case "system init" `Quick test_system_init;
169
+
Alcotest.test_case "system error" `Quick test_system_error;
170
+
Alcotest.test_case "is_user" `Quick test_is_user;
171
+
Alcotest.test_case "extract_text user" `Quick test_extract_text_from_user;
172
+
Alcotest.test_case "extract_text assistant" `Quick
173
+
test_extract_text_from_assistant;
174
+
Alcotest.test_case "extract_tool_uses user" `Quick test_extract_tools_user;
175
+
Alcotest.test_case "session_id system" `Quick test_session_id_from_system;
176
+
Alcotest.test_case "session_id user" `Quick test_session_id_from_user;
177
+
] )
+2
test/test_message.mli
+2
test/test_message.mli
+80
test/test_model.ml
+80
test/test_model.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Model module: of_string/to_string roundtrips and all variants. *)
7
+
8
+
let known_models =
9
+
[
10
+
(`Sonnet_4_5, "claude-sonnet-4-5");
11
+
(`Sonnet_4, "claude-sonnet-4");
12
+
(`Sonnet_3_5, "claude-sonnet-3-5");
13
+
(`Opus_4_5, "claude-opus-4-5");
14
+
(`Opus_4_1, "claude-opus-4-1");
15
+
(`Opus_4, "claude-opus-4");
16
+
(`Haiku_4, "claude-haiku-4");
17
+
]
18
+
19
+
let test_to_string_known () =
20
+
List.iter
21
+
(fun (model, expected) ->
22
+
Alcotest.(check string)
23
+
("to_string " ^ expected) expected
24
+
(Claude.Model.to_string model))
25
+
known_models
26
+
27
+
let test_of_string_known () =
28
+
List.iter
29
+
(fun (expected_model, str) ->
30
+
let actual = Claude.Model.of_string str in
31
+
Alcotest.(check string)
32
+
("of_string " ^ str)
33
+
(Claude.Model.to_string expected_model)
34
+
(Claude.Model.to_string actual))
35
+
known_models
36
+
37
+
let test_roundtrip_known () =
38
+
List.iter
39
+
(fun (model, _) ->
40
+
let s = Claude.Model.to_string model in
41
+
let back = Claude.Model.of_string s in
42
+
Alcotest.(check string) ("roundtrip " ^ s) s (Claude.Model.to_string back))
43
+
known_models
44
+
45
+
let test_custom_model () =
46
+
let custom = `Custom "my-special-model" in
47
+
Alcotest.(check string)
48
+
"custom to_string" "my-special-model"
49
+
(Claude.Model.to_string custom)
50
+
51
+
let test_custom_roundtrip () =
52
+
let s = "future-model-v99" in
53
+
let model = Claude.Model.of_string s in
54
+
Alcotest.(check string) "custom roundtrip" s (Claude.Model.to_string model)
55
+
56
+
let test_unknown_string_becomes_custom () =
57
+
let s = "not-a-known-model" in
58
+
match Claude.Model.of_string s with
59
+
| `Custom v -> Alcotest.(check string) "custom value" s v
60
+
| _ -> Alcotest.fail "Expected Custom variant for unknown model string"
61
+
62
+
let test_pp_output () =
63
+
let buf = Buffer.create 32 in
64
+
let ppf = Format.formatter_of_buffer buf in
65
+
Claude.Model.pp ppf `Sonnet_4_5;
66
+
Format.pp_print_flush ppf ();
67
+
Alcotest.(check string) "pp output" "claude-sonnet-4-5" (Buffer.contents buf)
68
+
69
+
let suite =
70
+
( "model",
71
+
[
72
+
Alcotest.test_case "to_string known models" `Quick test_to_string_known;
73
+
Alcotest.test_case "of_string known models" `Quick test_of_string_known;
74
+
Alcotest.test_case "roundtrip known models" `Quick test_roundtrip_known;
75
+
Alcotest.test_case "custom model to_string" `Quick test_custom_model;
76
+
Alcotest.test_case "custom model roundtrip" `Quick test_custom_roundtrip;
77
+
Alcotest.test_case "unknown string becomes Custom" `Quick
78
+
test_unknown_string_becomes_custom;
79
+
Alcotest.test_case "pp output" `Quick test_pp_output;
80
+
] )
+2
test/test_model.mli
+2
test/test_model.mli
+173
test/test_options.ml
+173
test/test_options.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Options module: default, builder pattern, accessors. *)
7
+
8
+
module O = Claude.Options
9
+
10
+
let test_default_values () =
11
+
let opts = O.default in
12
+
Alcotest.(check (list string)) "allowed_tools" [] (O.allowed_tools opts);
13
+
Alcotest.(check (list string)) "disallowed_tools" [] (O.disallowed_tools opts);
14
+
Alcotest.(check int) "max_thinking_tokens" 8000 (O.max_thinking_tokens opts);
15
+
Alcotest.(check (option string)) "system_prompt" None (O.system_prompt opts);
16
+
Alcotest.(check (option string))
17
+
"append_system_prompt" None
18
+
(O.append_system_prompt opts);
19
+
Alcotest.(check bool)
20
+
"continue_conversation" false
21
+
(O.continue_conversation opts);
22
+
Alcotest.(check (option string)) "resume" None (O.resume opts);
23
+
Alcotest.(check (list string)) "add_dirs" [] (O.add_dirs opts)
24
+
25
+
let test_with_allowed_tools () =
26
+
let opts = O.default |> O.with_allowed_tools [ "Bash"; "Read" ] in
27
+
Alcotest.(check (list string))
28
+
"allowed_tools" [ "Bash"; "Read" ] (O.allowed_tools opts)
29
+
30
+
let test_with_disallowed_tools () =
31
+
let opts = O.default |> O.with_disallowed_tools [ "Edit" ] in
32
+
Alcotest.(check (list string))
33
+
"disallowed_tools" [ "Edit" ] (O.disallowed_tools opts)
34
+
35
+
let test_with_max_thinking_tokens () =
36
+
let opts = O.default |> O.with_max_thinking_tokens 16000 in
37
+
Alcotest.(check int) "max_thinking_tokens" 16000 (O.max_thinking_tokens opts)
38
+
39
+
let test_with_system_prompt () =
40
+
let opts = O.default |> O.with_system_prompt "You are a helpful assistant" in
41
+
Alcotest.(check (option string))
42
+
"system_prompt" (Some "You are a helpful assistant") (O.system_prompt opts)
43
+
44
+
let test_with_append_system_prompt () =
45
+
let opts = O.default |> O.with_append_system_prompt "Extra context" in
46
+
Alcotest.(check (option string))
47
+
"append_system_prompt" (Some "Extra context")
48
+
(O.append_system_prompt opts)
49
+
50
+
let test_with_permission_mode () =
51
+
let opts =
52
+
O.default |> O.with_permission_mode Claude.Permissions.Mode.Accept_edits
53
+
in
54
+
match O.permission_mode opts with
55
+
| Some mode ->
56
+
Alcotest.(check string)
57
+
"mode" "acceptEdits"
58
+
(Claude.Permissions.Mode.to_string mode)
59
+
| None -> Alcotest.fail "Expected permission mode"
60
+
61
+
let test_with_model () =
62
+
let opts = O.default |> O.with_model `Opus_4 in
63
+
match O.model opts with
64
+
| Some m ->
65
+
Alcotest.(check string) "model" "claude-opus-4" (Claude.Model.to_string m)
66
+
| None -> Alcotest.fail "Expected model"
67
+
68
+
let test_with_continue_conversation () =
69
+
let opts = O.default |> O.with_continue_conversation true in
70
+
Alcotest.(check bool) "continue" true (O.continue_conversation opts)
71
+
72
+
let test_with_resume () =
73
+
let opts = O.default |> O.with_resume "session-123" in
74
+
Alcotest.(check (option string)) "resume" (Some "session-123") (O.resume opts)
75
+
76
+
let test_with_max_turns () =
77
+
let opts = O.default |> O.with_max_turns 5 in
78
+
Alcotest.(check (option int)) "max_turns" (Some 5) (O.max_turns opts)
79
+
80
+
let test_with_env () =
81
+
let opts = O.default |> O.with_env [ ("FOO", "bar"); ("BAZ", "qux") ] in
82
+
let env = O.env opts in
83
+
Alcotest.(check int) "env count" 2 (List.length env)
84
+
85
+
let test_with_max_budget_usd () =
86
+
let opts = O.default |> O.with_max_budget_usd 1.5 in
87
+
match O.max_budget_usd opts with
88
+
| Some b -> Alcotest.(check bool) "budget" true (abs_float (b -. 1.5) < 0.001)
89
+
| None -> Alcotest.fail "Expected budget"
90
+
91
+
let test_with_fallback_model () =
92
+
let opts = O.default |> O.with_fallback_model `Haiku_4 in
93
+
match O.fallback_model opts with
94
+
| Some m ->
95
+
Alcotest.(check string)
96
+
"fallback" "claude-haiku-4" (Claude.Model.to_string m)
97
+
| None -> Alcotest.fail "Expected fallback model"
98
+
99
+
let test_with_no_settings () =
100
+
let opts = O.default |> O.with_no_settings in
101
+
match O.setting_sources opts with
102
+
| Some [] -> ()
103
+
| Some _ -> Alcotest.fail "Expected empty setting_sources"
104
+
| None -> Alcotest.fail "Expected Some [] for no_settings"
105
+
106
+
let test_with_max_buffer_size () =
107
+
let opts = O.default |> O.with_max_buffer_size 5_000_000 in
108
+
Alcotest.(check (option int))
109
+
"max_buffer_size" (Some 5_000_000) (O.max_buffer_size opts)
110
+
111
+
let test_with_user () =
112
+
let opts = O.default |> O.with_user "testuser" in
113
+
Alcotest.(check (option string)) "user" (Some "testuser") (O.user opts)
114
+
115
+
let test_with_extra_args () =
116
+
let opts =
117
+
O.default
118
+
|> O.with_extra_args [ ("--verbose", None); ("--format", Some "json") ]
119
+
in
120
+
Alcotest.(check int) "extra_args" 2 (List.length (O.extra_args opts))
121
+
122
+
let test_chained_builders () =
123
+
let opts =
124
+
O.default |> O.with_model `Sonnet_4_5 |> O.with_max_budget_usd 2.0
125
+
|> O.with_max_turns 10
126
+
|> O.with_permission_mode Claude.Permissions.Mode.Default
127
+
in
128
+
Alcotest.(check (option int)) "max_turns" (Some 10) (O.max_turns opts);
129
+
(match O.model opts with
130
+
| Some m ->
131
+
Alcotest.(check string)
132
+
"model" "claude-sonnet-4-5" (Claude.Model.to_string m)
133
+
| None -> Alcotest.fail "Expected model");
134
+
match O.max_budget_usd opts with
135
+
| Some b -> Alcotest.(check bool) "budget" true (abs_float (b -. 2.0) < 0.001)
136
+
| None -> Alcotest.fail "Expected budget"
137
+
138
+
let test_pp_does_not_crash () =
139
+
let opts = O.default in
140
+
let buf = Buffer.create 64 in
141
+
let ppf = Format.formatter_of_buffer buf in
142
+
O.pp ppf opts;
143
+
Format.pp_print_flush ppf ();
144
+
Alcotest.(check bool) "pp output" true (Buffer.contents buf <> "")
145
+
146
+
let suite =
147
+
( "options",
148
+
[
149
+
Alcotest.test_case "default values" `Quick test_default_values;
150
+
Alcotest.test_case "with_allowed_tools" `Quick test_with_allowed_tools;
151
+
Alcotest.test_case "with_disallowed_tools" `Quick
152
+
test_with_disallowed_tools;
153
+
Alcotest.test_case "with_max_thinking_tokens" `Quick
154
+
test_with_max_thinking_tokens;
155
+
Alcotest.test_case "with_system_prompt" `Quick test_with_system_prompt;
156
+
Alcotest.test_case "with_append_system_prompt" `Quick
157
+
test_with_append_system_prompt;
158
+
Alcotest.test_case "with_permission_mode" `Quick test_with_permission_mode;
159
+
Alcotest.test_case "with_model" `Quick test_with_model;
160
+
Alcotest.test_case "with_continue_conversation" `Quick
161
+
test_with_continue_conversation;
162
+
Alcotest.test_case "with_resume" `Quick test_with_resume;
163
+
Alcotest.test_case "with_max_turns" `Quick test_with_max_turns;
164
+
Alcotest.test_case "with_env" `Quick test_with_env;
165
+
Alcotest.test_case "with_max_budget_usd" `Quick test_with_max_budget_usd;
166
+
Alcotest.test_case "with_fallback_model" `Quick test_with_fallback_model;
167
+
Alcotest.test_case "with_no_settings" `Quick test_with_no_settings;
168
+
Alcotest.test_case "with_max_buffer_size" `Quick test_with_max_buffer_size;
169
+
Alcotest.test_case "with_user" `Quick test_with_user;
170
+
Alcotest.test_case "with_extra_args" `Quick test_with_extra_args;
171
+
Alcotest.test_case "chained builders" `Quick test_chained_builders;
172
+
Alcotest.test_case "pp does not crash" `Quick test_pp_does_not_crash;
173
+
] )
+2
test/test_options.mli
+2
test/test_options.mli
+95
test/test_outgoing.ml
+95
test/test_outgoing.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module O = Claude.Outgoing
7
+
module M = Claude.Message
8
+
module C = Claude.Control
9
+
10
+
let test_encode_user_message () =
11
+
let user = M.User.of_string "hello" in
12
+
let msg = O.Message (M.User user) in
13
+
let json = O.to_json msg in
14
+
match json with Jsont.Object _ -> () | _ -> Alcotest.fail "Expected object"
15
+
16
+
let mk_control_request ?(request_id = "cr-1") request : C.control_request =
17
+
{
18
+
type_ = `Control_request;
19
+
request_id;
20
+
request;
21
+
unknown = Claude.Unknown.empty;
22
+
}
23
+
24
+
let mk_control_response response : C.control_response =
25
+
{ type_ = `Control_response; response; unknown = Claude.Unknown.empty }
26
+
27
+
let test_encode_control_response () =
28
+
let resp = C.Response.success ~request_id:"r1" () in
29
+
let envelope = mk_control_response resp in
30
+
let msg = O.Control_response envelope in
31
+
let json = O.to_json msg in
32
+
match json with Jsont.Object _ -> () | _ -> Alcotest.fail "Expected object"
33
+
34
+
let test_encode_control_request () =
35
+
let req = C.Request.interrupt () in
36
+
let envelope = mk_control_request req in
37
+
let msg = O.Control_request envelope in
38
+
let json = O.to_json msg in
39
+
match json with Jsont.Object _ -> () | _ -> Alcotest.fail "Expected object"
40
+
41
+
let test_jsont_roundtrip_user () =
42
+
let user = M.User.of_string "test" in
43
+
let msg = O.Message (M.User user) in
44
+
match Jsont.Json.encode O.jsont msg with
45
+
| Ok json -> (
46
+
match Jsont.Json.decode O.jsont json with
47
+
| Ok (O.Message (M.User _)) -> ()
48
+
| Ok _ -> Alcotest.fail "Wrong variant after decode"
49
+
| Error e -> Alcotest.fail e)
50
+
| Error e -> Alcotest.fail e
51
+
52
+
let test_jsont_roundtrip_control_response () =
53
+
let resp = C.Response.success ~request_id:"r2" () in
54
+
let envelope = mk_control_response resp in
55
+
let msg = O.Control_response envelope in
56
+
match Jsont.Json.encode O.jsont msg with
57
+
| Ok json -> (
58
+
match Jsont.Json.decode O.jsont json with
59
+
| Ok (O.Control_response _) -> ()
60
+
| Ok _ -> Alcotest.fail "Wrong variant after decode"
61
+
| Error e -> Alcotest.fail e)
62
+
| Error e -> Alcotest.fail e
63
+
64
+
let test_pp_does_not_crash () =
65
+
let user = M.User.of_string "pp test" in
66
+
let msg = O.Message (M.User user) in
67
+
let buf = Buffer.create 64 in
68
+
let ppf = Format.formatter_of_buffer buf in
69
+
O.pp ppf msg;
70
+
Format.pp_print_flush ppf ();
71
+
Alcotest.(check bool) "pp output" true (Buffer.contents buf <> "")
72
+
73
+
let test_of_json_user () =
74
+
let user = M.User.of_string "roundtrip" in
75
+
let msg = O.Message (M.User user) in
76
+
let json = O.to_json msg in
77
+
let back = O.of_json json in
78
+
match back with
79
+
| O.Message (M.User _) -> ()
80
+
| _ -> Alcotest.fail "Expected user message back"
81
+
82
+
let suite =
83
+
( "outgoing",
84
+
[
85
+
Alcotest.test_case "encode user message" `Quick test_encode_user_message;
86
+
Alcotest.test_case "encode control response" `Quick
87
+
test_encode_control_response;
88
+
Alcotest.test_case "encode control request" `Quick
89
+
test_encode_control_request;
90
+
Alcotest.test_case "jsont roundtrip user" `Quick test_jsont_roundtrip_user;
91
+
Alcotest.test_case "jsont roundtrip control response" `Quick
92
+
test_jsont_roundtrip_control_response;
93
+
Alcotest.test_case "pp does not crash" `Quick test_pp_does_not_crash;
94
+
Alcotest.test_case "of_json user" `Quick test_of_json_user;
95
+
] )
+2
test/test_outgoing.mli
+2
test/test_outgoing.mli
+182
test/test_permissions.ml
+182
test/test_permissions.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Permissions module: Mode, Rule, Decision, callbacks. *)
7
+
8
+
module P = Claude.Permissions
9
+
10
+
(* Mode tests *)
11
+
let test_mode_to_string () =
12
+
let cases =
13
+
[
14
+
(P.Mode.Default, "default");
15
+
(P.Mode.Accept_edits, "acceptEdits");
16
+
(P.Mode.Plan, "plan");
17
+
(P.Mode.Bypass_permissions, "bypassPermissions");
18
+
]
19
+
in
20
+
List.iter
21
+
(fun (mode, expected) ->
22
+
Alcotest.(check string) expected expected (P.Mode.to_string mode))
23
+
cases
24
+
25
+
let test_mode_of_string () =
26
+
let cases =
27
+
[
28
+
("default", P.Mode.Default);
29
+
("acceptEdits", P.Mode.Accept_edits);
30
+
("plan", P.Mode.Plan);
31
+
("bypassPermissions", P.Mode.Bypass_permissions);
32
+
]
33
+
in
34
+
List.iter
35
+
(fun (s, expected) ->
36
+
Alcotest.(check string)
37
+
s
38
+
(P.Mode.to_string expected)
39
+
(P.Mode.to_string (P.Mode.of_string s)))
40
+
cases
41
+
42
+
let test_mode_of_string_invalid () =
43
+
match P.Mode.of_string "invalid_mode" with
44
+
| exception Invalid_argument _ -> ()
45
+
| _ -> Alcotest.fail "Expected Invalid_argument"
46
+
47
+
let test_mode_roundtrip_proto () =
48
+
let modes =
49
+
[
50
+
P.Mode.Default;
51
+
P.Mode.Accept_edits;
52
+
P.Mode.Plan;
53
+
P.Mode.Bypass_permissions;
54
+
]
55
+
in
56
+
List.iter
57
+
(fun mode ->
58
+
let back = P.Mode.of_string (P.Mode.to_string mode) in
59
+
Alcotest.(check string)
60
+
("roundtrip " ^ P.Mode.to_string mode)
61
+
(P.Mode.to_string mode) (P.Mode.to_string back))
62
+
modes
63
+
64
+
(* Rule tests *)
65
+
let test_rule_create () =
66
+
let rule = P.Rule.create ~tool_name:"Bash" () in
67
+
Alcotest.(check string) "tool_name" "Bash" (P.Rule.tool_name rule);
68
+
Alcotest.(check (option string))
69
+
"no rule_content" None (P.Rule.rule_content rule)
70
+
71
+
let test_rule_create_with_content () =
72
+
let rule = P.Rule.create ~tool_name:"Edit" ~rule_content:"allow *.ml" () in
73
+
Alcotest.(check string) "tool_name" "Edit" (P.Rule.tool_name rule);
74
+
Alcotest.(check (option string))
75
+
"rule_content" (Some "allow *.ml") (P.Rule.rule_content rule)
76
+
77
+
let test_rule_proto_roundtrip () =
78
+
let rule = P.Rule.create ~tool_name:"Read" ~rule_content:"*.txt" () in
79
+
let json = Jsont.Json.encode P.Rule.jsont rule |> Result.get_ok in
80
+
let back = Jsont.Json.decode P.Rule.jsont json |> Result.get_ok in
81
+
Alcotest.(check string) "tool_name" "Read" (P.Rule.tool_name back);
82
+
Alcotest.(check (option string))
83
+
"rule_content" (Some "*.txt") (P.Rule.rule_content back)
84
+
85
+
(* Decision tests *)
86
+
let test_decision_allow () =
87
+
let d = P.Decision.allow () in
88
+
Alcotest.(check bool) "is_allow" true (P.Decision.is_allow d);
89
+
Alcotest.(check bool) "not is_deny" false (P.Decision.is_deny d);
90
+
Alcotest.(check (option string))
91
+
"no deny_message" None
92
+
(P.Decision.deny_message d);
93
+
Alcotest.(check bool)
94
+
"deny_interrupt false" false
95
+
(P.Decision.deny_interrupt d)
96
+
97
+
let test_allow_updated_input () =
98
+
let input =
99
+
Claude.Tool_input.empty |> Claude.Tool_input.add_string "x" "modified"
100
+
in
101
+
let d = P.Decision.allow ~updated_input:input () in
102
+
Alcotest.(check bool) "is_allow" true (P.Decision.is_allow d);
103
+
match P.Decision.updated_input d with
104
+
| Some inp ->
105
+
Alcotest.(check (option string))
106
+
"updated input" (Some "modified")
107
+
(Claude.Tool_input.string inp "x")
108
+
| None -> Alcotest.fail "Expected updated_input"
109
+
110
+
let test_decision_deny () =
111
+
let d = P.Decision.deny ~message:"not allowed" ~interrupt:true in
112
+
Alcotest.(check bool) "is_deny" true (P.Decision.is_deny d);
113
+
Alcotest.(check bool) "not is_allow" false (P.Decision.is_allow d);
114
+
Alcotest.(check (option string))
115
+
"deny_message" (Some "not allowed")
116
+
(P.Decision.deny_message d);
117
+
Alcotest.(check bool) "deny_interrupt" true (P.Decision.deny_interrupt d)
118
+
119
+
let test_decision_deny_no_interrupt () =
120
+
let d = P.Decision.deny ~message:"soft deny" ~interrupt:false in
121
+
Alcotest.(check bool) "deny_interrupt" false (P.Decision.deny_interrupt d)
122
+
123
+
let test_deny_updated_none () =
124
+
let d = P.Decision.deny ~message:"no" ~interrupt:false in
125
+
Alcotest.(check bool)
126
+
"no updated_input" true
127
+
(Option.is_none (P.Decision.updated_input d))
128
+
129
+
(* Callback tests *)
130
+
let test_default_allow_callback () =
131
+
let ctx =
132
+
{
133
+
P.tool_name = "Bash";
134
+
input = Claude.Tool_input.empty;
135
+
suggested_rules = [];
136
+
}
137
+
in
138
+
let d = P.default_allow ctx in
139
+
Alcotest.(check bool) "allows" true (P.Decision.is_allow d)
140
+
141
+
let test_discovery_callback () =
142
+
let log = ref [] in
143
+
let cb = P.discovery log in
144
+
let rule = P.Rule.create ~tool_name:"Bash" () in
145
+
let ctx =
146
+
{
147
+
P.tool_name = "Bash";
148
+
input = Claude.Tool_input.empty;
149
+
suggested_rules = [ rule ];
150
+
}
151
+
in
152
+
let d = cb ctx in
153
+
Alcotest.(check bool) "allows" true (P.Decision.is_allow d);
154
+
Alcotest.(check int) "logged 1 rule" 1 (List.length !log);
155
+
Alcotest.(check string)
156
+
"logged tool_name" "Bash"
157
+
(P.Rule.tool_name (List.hd !log))
158
+
159
+
let suite =
160
+
( "permissions",
161
+
[
162
+
Alcotest.test_case "mode to_string" `Quick test_mode_to_string;
163
+
Alcotest.test_case "mode of_string" `Quick test_mode_of_string;
164
+
Alcotest.test_case "mode of_string invalid" `Quick
165
+
test_mode_of_string_invalid;
166
+
Alcotest.test_case "mode proto roundtrip" `Quick test_mode_roundtrip_proto;
167
+
Alcotest.test_case "rule create" `Quick test_rule_create;
168
+
Alcotest.test_case "rule create with content" `Quick
169
+
test_rule_create_with_content;
170
+
Alcotest.test_case "rule proto roundtrip" `Quick test_rule_proto_roundtrip;
171
+
Alcotest.test_case "decision allow" `Quick test_decision_allow;
172
+
Alcotest.test_case "decision allow with updated input" `Quick
173
+
test_allow_updated_input;
174
+
Alcotest.test_case "decision deny" `Quick test_decision_deny;
175
+
Alcotest.test_case "decision deny no interrupt" `Quick
176
+
test_decision_deny_no_interrupt;
177
+
Alcotest.test_case "decision deny updated_input none" `Quick
178
+
test_deny_updated_none;
179
+
Alcotest.test_case "default_allow callback" `Quick
180
+
test_default_allow_callback;
181
+
Alcotest.test_case "discovery callback" `Quick test_discovery_callback;
182
+
] )
+2
test/test_permissions.mli
+2
test/test_permissions.mli
+148
test/test_response.ml
+148
test/test_response.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Response module: of_message conversion, event types. *)
7
+
8
+
module R = Claude.Response
9
+
module M = Claude.Message
10
+
module CB = Claude.Content_block
11
+
12
+
let mk_assistant blocks model =
13
+
M.Assistant (M.Assistant.create ~content:blocks ~model ())
14
+
15
+
let mk_system_init ?(session_id = "s") ?(model = "m") () =
16
+
M.System (M.System.init ~session_id ~model ())
17
+
18
+
let mk_system_error err = M.System (M.System.error ~error:err)
19
+
20
+
let mk_result ?(duration_ms = 100) ?(num_turns = 1) ?(session_id = "s")
21
+
?(is_error = false) () =
22
+
M.Result
23
+
(M.Result.create ~subtype:"success" ~duration_ms ~duration_api_ms:50
24
+
~is_error ~num_turns ~session_id ())
25
+
26
+
(* User messages produce no responses *)
27
+
let test_user_produces_empty () =
28
+
let msg = M.user_string "hello" in
29
+
Alcotest.(check int) "empty" 0 (List.length (R.of_message msg))
30
+
31
+
(* Assistant with text produces Text events *)
32
+
let test_assistant_text () =
33
+
let msg = mk_assistant [ CB.text "response" ] "claude-sonnet-4" in
34
+
match R.of_message msg with
35
+
| [ R.Text t ] ->
36
+
Alcotest.(check string) "content" "response" (R.Text.content t)
37
+
| _ -> Alcotest.fail "Expected single Text event"
38
+
39
+
(* Assistant with multiple blocks produces multiple events *)
40
+
let test_assistant_multiple_blocks () =
41
+
let input = Claude.Tool_input.empty in
42
+
let msg =
43
+
mk_assistant
44
+
[
45
+
CB.text "thinking out loud"; CB.tool_use ~id:"tu-1" ~name:"Bash" ~input;
46
+
]
47
+
"claude-sonnet-4"
48
+
in
49
+
let events = R.of_message msg in
50
+
Alcotest.(check int) "2 events" 2 (List.length events);
51
+
(match List.hd events with
52
+
| R.Text t ->
53
+
Alcotest.(check string) "text" "thinking out loud" (R.Text.content t)
54
+
| _ -> Alcotest.fail "Expected Text first");
55
+
match List.nth events 1 with
56
+
| R.Tool_use tu ->
57
+
Alcotest.(check string) "tool id" "tu-1" (R.Tool_use.id tu);
58
+
Alcotest.(check string) "tool name" "Bash" (R.Tool_use.name tu)
59
+
| _ -> Alcotest.fail "Expected Tool_use second"
60
+
61
+
(* Assistant with thinking block *)
62
+
let test_assistant_thinking () =
63
+
let msg =
64
+
mk_assistant
65
+
[ CB.thinking ~thinking:"let me think" ~signature:"sig1" ]
66
+
"claude-sonnet-4"
67
+
in
68
+
match R.of_message msg with
69
+
| [ R.Thinking t ] ->
70
+
Alcotest.(check string) "content" "let me think" (R.Thinking.content t);
71
+
Alcotest.(check string) "signature" "sig1" (R.Thinking.signature t)
72
+
| _ -> Alcotest.fail "Expected single Thinking event"
73
+
74
+
(* System init produces Init event *)
75
+
let test_system_init () =
76
+
let msg = mk_system_init ~session_id:"sess-1" ~model:"claude-opus-4" () in
77
+
match R.of_message msg with
78
+
| [ R.Init init ] ->
79
+
Alcotest.(check (option string))
80
+
"session_id" (Some "sess-1") (R.Init.session_id init);
81
+
Alcotest.(check (option string))
82
+
"model" (Some "claude-opus-4") (R.Init.model init)
83
+
| _ -> Alcotest.fail "Expected single Init event"
84
+
85
+
(* System error produces Error event *)
86
+
let test_system_error () =
87
+
let msg = mk_system_error "bad stuff" in
88
+
match R.of_message msg with
89
+
| [ R.Error err ] ->
90
+
Alcotest.(check string) "message" "bad stuff" (R.Error.message err);
91
+
Alcotest.(check bool) "is_system_error" true (R.Error.is_system_error err);
92
+
Alcotest.(check bool)
93
+
"not is_assistant_error" false
94
+
(R.Error.is_assistant_error err)
95
+
| _ -> Alcotest.fail "Expected single Error event"
96
+
97
+
(* Result message produces Complete event *)
98
+
let test_result_complete () =
99
+
let msg = mk_result ~duration_ms:500 ~num_turns:3 ~session_id:"sess-42" () in
100
+
match R.of_message msg with
101
+
| [ R.Complete c ] ->
102
+
Alcotest.(check int) "duration_ms" 500 (R.Complete.duration_ms c);
103
+
Alcotest.(check int) "num_turns" 3 (R.Complete.num_turns c);
104
+
Alcotest.(check string) "session_id" "sess-42" (R.Complete.session_id c)
105
+
| _ -> Alcotest.fail "Expected single Complete event"
106
+
107
+
let test_assistant_error () =
108
+
let asst =
109
+
M.Assistant.create
110
+
~content:[ CB.text "err" ]
111
+
~model:"claude-sonnet-4" ~error:`Rate_limit ()
112
+
in
113
+
let msg = M.Assistant asst in
114
+
match R.of_message msg with
115
+
| [ R.Error err ] ->
116
+
Alcotest.(check bool)
117
+
"is_assistant_error" true
118
+
(R.Error.is_assistant_error err);
119
+
Alcotest.(check string)
120
+
"message" "Rate limit exceeded" (R.Error.message err)
121
+
| _ -> Alcotest.fail "Expected single Error event for assistant error"
122
+
123
+
let test_pp_does_not_crash () =
124
+
let events = R.of_message (mk_assistant [ CB.text "t" ] "m") in
125
+
let buf = Buffer.create 64 in
126
+
let ppf = Format.formatter_of_buffer buf in
127
+
List.iter
128
+
(fun ev ->
129
+
R.pp ppf ev;
130
+
Format.pp_print_newline ppf ())
131
+
events;
132
+
Format.pp_print_flush ppf ();
133
+
Alcotest.(check bool) "pp output" true (Buffer.contents buf <> "")
134
+
135
+
let suite =
136
+
( "response",
137
+
[
138
+
Alcotest.test_case "user produces empty" `Quick test_user_produces_empty;
139
+
Alcotest.test_case "assistant text" `Quick test_assistant_text;
140
+
Alcotest.test_case "assistant multiple blocks" `Quick
141
+
test_assistant_multiple_blocks;
142
+
Alcotest.test_case "assistant thinking" `Quick test_assistant_thinking;
143
+
Alcotest.test_case "system init" `Quick test_system_init;
144
+
Alcotest.test_case "system error" `Quick test_system_error;
145
+
Alcotest.test_case "result complete" `Quick test_result_complete;
146
+
Alcotest.test_case "assistant error" `Quick test_assistant_error;
147
+
Alcotest.test_case "pp does not crash" `Quick test_pp_does_not_crash;
148
+
] )
+2
test/test_response.mli
+2
test/test_response.mli
+75
test/test_server_info.ml
+75
test/test_server_info.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Server_info module: construction, accessors, capability checks. *)
7
+
8
+
module SI = Claude.Server_info
9
+
10
+
let mk_info ?(version = "2.0.0") ?(capabilities = []) ?(commands = [])
11
+
?(output_styles = []) () =
12
+
let c =
13
+
Claude.Control.Server_info.create ~version ~capabilities ~commands
14
+
~output_styles ()
15
+
in
16
+
SI.of_control c
17
+
18
+
let test_version () =
19
+
let info = mk_info ~version:"3.1.0" () in
20
+
Alcotest.(check string) "version" "3.1.0" (SI.version info)
21
+
22
+
let test_capabilities () =
23
+
let info = mk_info ~capabilities:[ "hooks"; "structured-output" ] () in
24
+
Alcotest.(check (list string))
25
+
"capabilities"
26
+
[ "hooks"; "structured-output" ]
27
+
(SI.capabilities info)
28
+
29
+
let test_commands () =
30
+
let info = mk_info ~commands:[ "run"; "chat" ] () in
31
+
Alcotest.(check (list string)) "commands" [ "run"; "chat" ] (SI.commands info)
32
+
33
+
let test_output_styles () =
34
+
let info = mk_info ~output_styles:[ "json"; "stream-json" ] () in
35
+
Alcotest.(check (list string))
36
+
"output_styles" [ "json"; "stream-json" ] (SI.output_styles info)
37
+
38
+
let test_has_capability () =
39
+
let info = mk_info ~capabilities:[ "hooks"; "mcp" ] () in
40
+
Alcotest.(check bool) "has hooks" true (SI.has_capability info "hooks");
41
+
Alcotest.(check bool) "has mcp" true (SI.has_capability info "mcp");
42
+
Alcotest.(check bool) "no unknown" false (SI.has_capability info "unknown")
43
+
44
+
let test_supports_hooks () =
45
+
let with_hooks = mk_info ~capabilities:[ "hooks" ] () in
46
+
let without = mk_info ~capabilities:[ "other" ] () in
47
+
Alcotest.(check bool) "supports" true (SI.supports_hooks with_hooks);
48
+
Alcotest.(check bool) "not supports" false (SI.supports_hooks without)
49
+
50
+
let test_supports_structured_output () =
51
+
let with_so = mk_info ~capabilities:[ "structured-output" ] () in
52
+
let without = mk_info ~capabilities:[] () in
53
+
Alcotest.(check bool) "supports" true (SI.supports_structured_output with_so);
54
+
Alcotest.(check bool)
55
+
"not supports" false
56
+
(SI.supports_structured_output without)
57
+
58
+
let test_empty_capabilities () =
59
+
let info = mk_info ~capabilities:[] () in
60
+
Alcotest.(check bool) "no hooks" false (SI.supports_hooks info);
61
+
Alcotest.(check bool) "no so" false (SI.supports_structured_output info)
62
+
63
+
let suite =
64
+
( "server_info",
65
+
[
66
+
Alcotest.test_case "version" `Quick test_version;
67
+
Alcotest.test_case "capabilities" `Quick test_capabilities;
68
+
Alcotest.test_case "commands" `Quick test_commands;
69
+
Alcotest.test_case "output_styles" `Quick test_output_styles;
70
+
Alcotest.test_case "has_capability" `Quick test_has_capability;
71
+
Alcotest.test_case "supports_hooks" `Quick test_supports_hooks;
72
+
Alcotest.test_case "supports_structured_output" `Quick
73
+
test_supports_structured_output;
74
+
Alcotest.test_case "empty capabilities" `Quick test_empty_capabilities;
75
+
] )
+2
test/test_server_info.mli
+2
test/test_server_info.mli
+75
test/test_structured_output.ml
+75
test/test_structured_output.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Structured_output: creation, accessors, JSON roundtrip. *)
7
+
8
+
module SO = Claude.Structured_output
9
+
module J = Jsont.Json
10
+
11
+
let mk_schema () =
12
+
J.object'
13
+
[
14
+
J.mem (J.name "type") (J.string "object");
15
+
J.mem (J.name "properties")
16
+
(J.object'
17
+
[
18
+
J.mem (J.name "name")
19
+
(J.object' [ J.mem (J.name "type") (J.string "string") ]);
20
+
]);
21
+
J.mem (J.name "required") (J.list [ J.string "name" ]);
22
+
]
23
+
24
+
let test_of_json_schema () =
25
+
let schema = mk_schema () in
26
+
let so = SO.of_json_schema schema in
27
+
(* json_schema should return the schema we passed in *)
28
+
match SO.json_schema so with
29
+
| Jsont.Object _ -> ()
30
+
| _ -> Alcotest.fail "Expected object schema back"
31
+
32
+
let test_json_roundtrip () =
33
+
let schema = mk_schema () in
34
+
let so = SO.of_json_schema schema in
35
+
let json = SO.to_json so in
36
+
let back = SO.of_json json in
37
+
match SO.json_schema back with
38
+
| Jsont.Object _ -> ()
39
+
| _ -> Alcotest.fail "Expected object schema after roundtrip"
40
+
41
+
let test_jsont_encode_decode () =
42
+
let schema = J.object' [ J.mem (J.name "type") (J.string "string") ] in
43
+
let so = SO.of_json_schema schema in
44
+
match Jsont.Json.encode SO.jsont so with
45
+
| Ok json -> (
46
+
match Jsont.Json.decode SO.jsont json with
47
+
| Ok back -> (
48
+
match SO.json_schema back with
49
+
| Jsont.Object _ -> ()
50
+
| _ -> Alcotest.fail "Expected object after decode")
51
+
| Error e -> Alcotest.fail e)
52
+
| Error e -> Alcotest.fail e
53
+
54
+
let test_simple_string_schema () =
55
+
let schema = J.object' [ J.mem (J.name "type") (J.string "string") ] in
56
+
let so = SO.of_json_schema schema in
57
+
match SO.json_schema so with
58
+
| Jsont.Object _ -> ()
59
+
| _ -> Alcotest.fail "Expected object"
60
+
61
+
let test_of_json_invalid () =
62
+
(* of_json with bad data should raise Invalid_argument *)
63
+
match SO.of_json (Jsont.String ("not valid", Jsont.Meta.none)) with
64
+
| exception Invalid_argument _ -> ()
65
+
| _ -> Alcotest.fail "Expected Invalid_argument for bad JSON"
66
+
67
+
let suite =
68
+
( "structured_output",
69
+
[
70
+
Alcotest.test_case "of_json_schema" `Quick test_of_json_schema;
71
+
Alcotest.test_case "to_json/of_json roundtrip" `Quick test_json_roundtrip;
72
+
Alcotest.test_case "jsont encode/decode" `Quick test_jsont_encode_decode;
73
+
Alcotest.test_case "simple string schema" `Quick test_simple_string_schema;
74
+
Alcotest.test_case "of_json invalid" `Quick test_of_json_invalid;
75
+
] )
+2
test/test_structured_output.mli
+2
test/test_structured_output.mli
+127
test/test_tool.ml
+127
test/test_tool.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Tool module: creation, accessors, call, schema helpers.
7
+
Complements the tests already in test_claude.ml with edge cases. *)
8
+
9
+
module J = Jsont.Json
10
+
11
+
let test_tool_accessors () =
12
+
let t =
13
+
Claude.Tool.v ~name:"my_tool" ~description:"A tool"
14
+
~input_schema:(Claude.Tool.schema_object [] ~required:[])
15
+
~handler:(fun _ -> Ok (Claude.Tool.text_result "ok"))
16
+
in
17
+
Alcotest.(check string) "name" "my_tool" (Claude.Tool.name t);
18
+
Alcotest.(check string) "description" "A tool" (Claude.Tool.description t)
19
+
20
+
let test_call_with_missing_param () =
21
+
let t =
22
+
Claude.Tool.v ~name:"needs_param" ~description:"Needs a name"
23
+
~input_schema:
24
+
(Claude.Tool.schema_object
25
+
[ ("name", Claude.Tool.schema_string) ]
26
+
~required:[ "name" ])
27
+
~handler:(fun args ->
28
+
match Claude.Tool_input.string args "name" with
29
+
| Some name -> Ok (Claude.Tool.text_result ("Hi " ^ name))
30
+
| None -> Error "name is required")
31
+
in
32
+
let empty_input = Claude.Tool_input.of_json (J.object' []) in
33
+
match Claude.Tool.call t empty_input with
34
+
| Ok _ -> Alcotest.fail "Expected error for missing param"
35
+
| Error msg -> Alcotest.(check string) "error msg" "name is required" msg
36
+
37
+
let test_schema_object_no_required () =
38
+
let schema =
39
+
Claude.Tool.schema_object
40
+
[ ("opt_field", Claude.Tool.schema_string) ]
41
+
~required:[]
42
+
in
43
+
(* Just verify it doesn't crash and is a valid JSON object *)
44
+
match schema with
45
+
| Jsont.Object _ -> ()
46
+
| _ -> Alcotest.fail "Expected JSON object"
47
+
48
+
let test_schema_array_of_int () =
49
+
let schema = Claude.Tool.schema_array Claude.Tool.schema_int in
50
+
match schema with
51
+
| Jsont.Object _ -> ()
52
+
| _ -> Alcotest.fail "Expected JSON object for array schema"
53
+
54
+
let test_schema_string_enum_empty () =
55
+
let schema = Claude.Tool.schema_string_enum [] in
56
+
match schema with
57
+
| Jsont.Object _ -> ()
58
+
| _ -> Alcotest.fail "Expected JSON object"
59
+
60
+
let test_text_result_format () =
61
+
let result = Claude.Tool.text_result "test output" in
62
+
match result with
63
+
| Jsont.Array ([ Jsont.Object (_, _) ], _) -> ()
64
+
| _ -> Alcotest.fail "Expected array with one object"
65
+
66
+
let test_error_result_format () =
67
+
let result = Claude.Tool.error_result "bad input" in
68
+
match result with
69
+
| Jsont.Array ([ Jsont.Object (_, _) ], _) -> ()
70
+
| _ -> Alcotest.fail "Expected array with one object"
71
+
72
+
let test_handler_returns_complex_json () =
73
+
let t =
74
+
Claude.Tool.v ~name:"complex" ~description:"Returns complex JSON"
75
+
~input_schema:(Claude.Tool.schema_object [] ~required:[])
76
+
~handler:(fun _ ->
77
+
Ok
78
+
(J.list
79
+
[
80
+
J.object'
81
+
[
82
+
J.mem (J.name "type") (J.string "text");
83
+
J.mem (J.name "text") (J.string "line1");
84
+
];
85
+
J.object'
86
+
[
87
+
J.mem (J.name "type") (J.string "text");
88
+
J.mem (J.name "text") (J.string "line2");
89
+
];
90
+
]))
91
+
in
92
+
let input = Claude.Tool_input.of_json (J.object' []) in
93
+
match Claude.Tool.call t input with
94
+
| Ok (Jsont.Array (items, _)) ->
95
+
Alcotest.(check int) "two items" 2 (List.length items)
96
+
| Ok _ -> Alcotest.fail "Expected array"
97
+
| Error msg -> Alcotest.fail msg
98
+
99
+
let test_pp_does_not_crash () =
100
+
let t =
101
+
Claude.Tool.v ~name:"pp_test" ~description:"test pp"
102
+
~input_schema:(Claude.Tool.schema_object [] ~required:[])
103
+
~handler:(fun _ -> Ok (Claude.Tool.text_result "x"))
104
+
in
105
+
let buf = Buffer.create 64 in
106
+
let ppf = Format.formatter_of_buffer buf in
107
+
Claude.Tool.pp ppf t;
108
+
Format.pp_print_flush ppf ();
109
+
Alcotest.(check bool) "pp output" true (Buffer.contents buf <> "")
110
+
111
+
let suite =
112
+
( "tool",
113
+
[
114
+
Alcotest.test_case "accessors" `Quick test_tool_accessors;
115
+
Alcotest.test_case "call with missing param" `Quick
116
+
test_call_with_missing_param;
117
+
Alcotest.test_case "schema_object no required" `Quick
118
+
test_schema_object_no_required;
119
+
Alcotest.test_case "schema_array of int" `Quick test_schema_array_of_int;
120
+
Alcotest.test_case "schema_string_enum empty" `Quick
121
+
test_schema_string_enum_empty;
122
+
Alcotest.test_case "text_result format" `Quick test_text_result_format;
123
+
Alcotest.test_case "error_result format" `Quick test_error_result_format;
124
+
Alcotest.test_case "handler returns complex JSON" `Quick
125
+
test_handler_returns_complex_json;
126
+
Alcotest.test_case "pp does not crash" `Quick test_pp_does_not_crash;
127
+
] )
+2
test/test_tool.mli
+2
test/test_tool.mli
+155
test/test_tool_input.ml
+155
test/test_tool_input.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Tool_input: constructors, accessors, keys, is_empty. *)
7
+
8
+
module J = Jsont.Json
9
+
10
+
let test_empty () =
11
+
let t = Claude.Tool_input.empty in
12
+
Alcotest.(check bool) "empty is_empty" true (Claude.Tool_input.is_empty t);
13
+
Alcotest.(check (list string)) "empty keys" [] (Claude.Tool_input.keys t)
14
+
15
+
let test_add_string () =
16
+
let t =
17
+
Claude.Tool_input.empty |> Claude.Tool_input.add_string "name" "Alice"
18
+
in
19
+
Alcotest.(check (option string))
20
+
"get name" (Some "Alice")
21
+
(Claude.Tool_input.string t "name");
22
+
Alcotest.(check bool) "not empty" false (Claude.Tool_input.is_empty t)
23
+
24
+
let test_add_int () =
25
+
let t = Claude.Tool_input.empty |> Claude.Tool_input.add_int "count" 99 in
26
+
Alcotest.(check (option int))
27
+
"get count" (Some 99)
28
+
(Claude.Tool_input.int t "count")
29
+
30
+
let test_add_bool () =
31
+
let t = Claude.Tool_input.empty |> Claude.Tool_input.add_bool "flag" true in
32
+
Alcotest.(check (option bool))
33
+
"get flag" (Some true)
34
+
(Claude.Tool_input.bool t "flag")
35
+
36
+
let test_add_float () =
37
+
let t = Claude.Tool_input.empty |> Claude.Tool_input.add_float "pi" 3.14 in
38
+
match Claude.Tool_input.float t "pi" with
39
+
| Some f -> Alcotest.(check bool) "approx" true (abs_float (f -. 3.14) < 0.001)
40
+
| None -> Alcotest.fail "Expected float"
41
+
42
+
let test_keys () =
43
+
let t =
44
+
Claude.Tool_input.empty
45
+
|> Claude.Tool_input.add_string "a" "1"
46
+
|> Claude.Tool_input.add_int "b" 2
47
+
in
48
+
let keys = Claude.Tool_input.keys t in
49
+
Alcotest.(check int) "key count" 2 (List.length keys);
50
+
Alcotest.(check bool) "has a" true (List.mem "a" keys);
51
+
Alcotest.(check bool) "has b" true (List.mem "b" keys)
52
+
53
+
let test_missing_key_returns_none () =
54
+
let t = Claude.Tool_input.empty in
55
+
Alcotest.(check (option string))
56
+
"missing string" None
57
+
(Claude.Tool_input.string t "x");
58
+
Alcotest.(check (option int)) "missing int" None (Claude.Tool_input.int t "x");
59
+
Alcotest.(check (option bool))
60
+
"missing bool" None
61
+
(Claude.Tool_input.bool t "x")
62
+
63
+
let test_type_mismatch_returns_none () =
64
+
let t = Claude.Tool_input.empty |> Claude.Tool_input.add_string "val" "hi" in
65
+
Alcotest.(check (option int))
66
+
"string as int" None
67
+
(Claude.Tool_input.int t "val");
68
+
Alcotest.(check (option bool))
69
+
"string as bool" None
70
+
(Claude.Tool_input.bool t "val")
71
+
72
+
let test_of_json_roundtrip () =
73
+
let json = J.object' [ J.mem (J.name "key") (J.string "value") ] in
74
+
let t = Claude.Tool_input.of_json json in
75
+
Alcotest.(check (option string))
76
+
"roundtrip" (Some "value")
77
+
(Claude.Tool_input.string t "key")
78
+
79
+
let test_of_string_pairs () =
80
+
let t =
81
+
Claude.Tool_input.of_string_pairs [ ("x", "hello"); ("y", "world") ]
82
+
in
83
+
Alcotest.(check (option string))
84
+
"x" (Some "hello")
85
+
(Claude.Tool_input.string t "x");
86
+
Alcotest.(check (option string))
87
+
"y" (Some "world")
88
+
(Claude.Tool_input.string t "y")
89
+
90
+
let test_of_assoc () =
91
+
let t =
92
+
Claude.Tool_input.of_assoc
93
+
[
94
+
("num", Jsont.Number (42.0, Jsont.Meta.none));
95
+
("s", Jsont.String ("hi", Jsont.Meta.none));
96
+
]
97
+
in
98
+
Alcotest.(check (option int)) "num" (Some 42) (Claude.Tool_input.int t "num");
99
+
Alcotest.(check (option string))
100
+
"s" (Some "hi")
101
+
(Claude.Tool_input.string t "s")
102
+
103
+
let test_add_replaces_existing () =
104
+
let t =
105
+
Claude.Tool_input.empty
106
+
|> Claude.Tool_input.add_string "k" "old"
107
+
|> Claude.Tool_input.add_string "k" "new"
108
+
in
109
+
Alcotest.(check (option string))
110
+
"replaced" (Some "new")
111
+
(Claude.Tool_input.string t "k")
112
+
113
+
let test_string_list_accessor () =
114
+
let json =
115
+
J.object'
116
+
[
117
+
J.mem (J.name "tags")
118
+
(J.list [ J.string "a"; J.string "b"; J.string "c" ]);
119
+
]
120
+
in
121
+
let t = Claude.Tool_input.of_json json in
122
+
Alcotest.(check (option (list string)))
123
+
"string_list"
124
+
(Some [ "a"; "b"; "c" ])
125
+
(Claude.Tool_input.string_list t "tags")
126
+
127
+
let test_pp_does_not_crash () =
128
+
let t = Claude.Tool_input.empty |> Claude.Tool_input.add_string "k" "v" in
129
+
let buf = Buffer.create 32 in
130
+
let ppf = Format.formatter_of_buffer buf in
131
+
Claude.Tool_input.pp ppf t;
132
+
Format.pp_print_flush ppf ();
133
+
Alcotest.(check bool) "pp output" true (Buffer.contents buf <> "")
134
+
135
+
let suite =
136
+
( "tool_input",
137
+
[
138
+
Alcotest.test_case "empty" `Quick test_empty;
139
+
Alcotest.test_case "add_string" `Quick test_add_string;
140
+
Alcotest.test_case "add_int" `Quick test_add_int;
141
+
Alcotest.test_case "add_bool" `Quick test_add_bool;
142
+
Alcotest.test_case "add_float" `Quick test_add_float;
143
+
Alcotest.test_case "keys" `Quick test_keys;
144
+
Alcotest.test_case "missing key returns None" `Quick
145
+
test_missing_key_returns_none;
146
+
Alcotest.test_case "type mismatch returns None" `Quick
147
+
test_type_mismatch_returns_none;
148
+
Alcotest.test_case "of_json roundtrip" `Quick test_of_json_roundtrip;
149
+
Alcotest.test_case "of_string_pairs" `Quick test_of_string_pairs;
150
+
Alcotest.test_case "of_assoc" `Quick test_of_assoc;
151
+
Alcotest.test_case "add replaces existing" `Quick
152
+
test_add_replaces_existing;
153
+
Alcotest.test_case "string_list accessor" `Quick test_string_list_accessor;
154
+
Alcotest.test_case "pp does not crash" `Quick test_pp_does_not_crash;
155
+
] )
+2
test/test_tool_input.mli
+2
test/test_tool_input.mli
+43
test/test_transport.ml
+43
test/test_transport.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Transport module: pure helpers only (no I/O). Transport is I/O
7
+
heavy and requires Eio, so we test what we can. *)
8
+
9
+
(* Transport.src is a log source - verify it exists *)
10
+
let test_log_source_exists () =
11
+
let name = Logs.Src.name Claude.Transport.src in
12
+
Alcotest.(check bool) "has name" true (String.length name > 0)
13
+
14
+
(* Transport exceptions exist *)
15
+
let test_cli_not_found_exception () =
16
+
match raise (Claude.Transport.CLI_not_found "missing") with
17
+
| exception Claude.Transport.CLI_not_found msg ->
18
+
Alcotest.(check string) "msg" "missing" msg
19
+
| _ -> Alcotest.fail "Expected exception"
20
+
21
+
let test_process_error_exception () =
22
+
match raise (Claude.Transport.Process_error "failed") with
23
+
| exception Claude.Transport.Process_error msg ->
24
+
Alcotest.(check string) "msg" "failed" msg
25
+
| _ -> Alcotest.fail "Expected exception"
26
+
27
+
let test_connection_error_exception () =
28
+
match raise (Claude.Transport.Connection_error "refused") with
29
+
| exception Claude.Transport.Connection_error msg ->
30
+
Alcotest.(check string) "msg" "refused" msg
31
+
| _ -> Alcotest.fail "Expected exception"
32
+
33
+
let suite =
34
+
( "transport",
35
+
[
36
+
Alcotest.test_case "log source exists" `Quick test_log_source_exists;
37
+
Alcotest.test_case "CLI_not_found exception" `Quick
38
+
test_cli_not_found_exception;
39
+
Alcotest.test_case "Process_error exception" `Quick
40
+
test_process_error_exception;
41
+
Alcotest.test_case "Connection_error exception" `Quick
42
+
test_connection_error_exception;
43
+
] )
+2
test/test_transport.mli
+2
test/test_transport.mli
+51
test/test_unknown.ml
+51
test/test_unknown.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Unknown = Claude.Unknown
7
+
8
+
let test_empty_is_empty () =
9
+
Alcotest.(check bool) "empty is_empty" true (Unknown.is_empty Unknown.empty)
10
+
11
+
let test_non_empty_object () =
12
+
let assoc = [ ("extra", Jsont.String ("val", Jsont.Meta.none)) ] in
13
+
let unknown = Unknown.of_assoc assoc in
14
+
Alcotest.(check bool) "non-empty" false (Unknown.is_empty unknown)
15
+
16
+
let test_empty_object_value () =
17
+
let unknown = Unknown.of_assoc [] in
18
+
Alcotest.(check bool) "empty object" true (Unknown.is_empty unknown)
19
+
20
+
let test_assoc_roundtrip () =
21
+
let assoc =
22
+
[
23
+
("key1", Jsont.String ("val1", Jsont.Meta.none));
24
+
("key2", Jsont.Number (42.0, Jsont.Meta.none));
25
+
]
26
+
in
27
+
let unknown = Unknown.of_assoc assoc in
28
+
let back = Unknown.to_assoc unknown in
29
+
Alcotest.(check int) "assoc count" 2 (List.length back);
30
+
let keys = List.map fst back in
31
+
Alcotest.(check bool) "has key1" true (List.mem "key1" keys);
32
+
Alcotest.(check bool) "has key2" true (List.mem "key2" keys)
33
+
34
+
let test_pp_empty () =
35
+
let buf = Buffer.create 32 in
36
+
let ppf = Format.formatter_of_buffer buf in
37
+
Unknown.pp ppf Unknown.empty;
38
+
Format.pp_print_flush ppf ();
39
+
let output = Buffer.contents buf in
40
+
Alcotest.(check bool) "pp produces output" true (String.length output >= 0)
41
+
42
+
let suite =
43
+
( "unknown",
44
+
[
45
+
Alcotest.test_case "empty is_empty" `Quick test_empty_is_empty;
46
+
Alcotest.test_case "non-empty object" `Quick test_non_empty_object;
47
+
Alcotest.test_case "empty object value" `Quick test_empty_object_value;
48
+
Alcotest.test_case "of_assoc/to_assoc roundtrip" `Quick
49
+
test_assoc_roundtrip;
50
+
Alcotest.test_case "pp empty" `Quick test_pp_empty;
51
+
] )