OCaml Claude SDK using Eio and Jsont
Merge remote-tracking branch 'samoht/main'
+9284
-2802
+6
.gitignore
+6
.gitignore
+3
-3
ARCHITECTURE.md
+3
-3
ARCHITECTURE.md
···
212
212
{[
213
213
let block_rm = Hook.PreToolUse.handler (fun input ->
214
214
if input.tool_name = "Bash" then
215
-
match Tool_input.get_string input.tool_input "command" with
215
+
match Tool_input.string input.tool_input "command" with
216
216
| Some cmd when String.is_substring cmd ~substring:"rm -rf" ->
217
217
Hook.PreToolUse.deny ~reason:"Dangerous command"
218
218
| _ -> Hook.PreToolUse.allow ()
···
570
570
571
571
val set_model : t -> Model.t -> unit
572
572
val set_permission_mode : t -> Permission_mode.t -> unit
573
-
val get_server_info : t -> Server_info.t
573
+
val server_info : t -> Server_info.t
574
574
val interrupt : t -> unit
575
575
576
576
val session_id : t -> string option
···
915
915
(* Define hook to block dangerous commands *)
916
916
let block_dangerous_bash input =
917
917
if input.Claude.Hook.PreToolUse.tool_name = "Bash" then
918
-
match Claude.Tool_input.get_string input.tool_input "command" with
918
+
match Claude.Tool_input.string input.tool_input "command" with
919
919
| Some cmd when String.is_substring cmd ~substring:"rm -rf" ->
920
920
Claude.Hook.PreToolUse.deny ~reason:"Dangerous command blocked"
921
921
| _ -> Claude.Hook.PreToolUse.allow ()
+80
-26
README.md
+80
-26
README.md
···
1
-
# ClaudeIO - OCaml Eio Library for Claude Code CLI
1
+
# claude -- OCaml client library for Claude Code
2
2
3
-
An OCaml library that provides high-quality Eio-style bindings for the Claude Code CLI, enabling programmatic interaction with Claude through JSON streaming.
3
+
An Eio-based OCaml library for interacting with the Claude Code CLI using
4
+
JSON streaming.
4
5
5
6
## Overview
6
7
7
-
ClaudeIO wraps Claude Code CLI invocations in an idiomatic OCaml Eio interface, leveraging:
8
-
- JSON input/output streaming modes of the CLI
9
-
- Ezjsonm for JSON message handling
10
-
- Eio abstractions including `Buf_read` and `Seq` for efficient streaming
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.
11
12
12
13
## Features
13
14
14
-
- **Streaming JSON Interface**: Communicate with Claude using structured JSON messages
15
-
- **Eio Integration**: Built on modern OCaml concurrency primitives
16
-
- **Type-safe API**: Strongly typed OCaml interface for Claude interactions
17
-
- **Efficient Buffering**: Uses Eio's buffer management for optimal performance
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
18
23
19
24
## Installation
20
25
21
-
```bash
22
-
opam install claudeio
26
+
Install with opam:
27
+
28
+
```sh
29
+
$ opam install claude
30
+
```
31
+
32
+
If opam cannot find the package, it may not yet be released in the public
33
+
`opam-repository`. Add the overlay repository, then install it:
34
+
35
+
```sh
36
+
$ opam repo add samoht https://tangled.org/gazagnaire.org/opam-overlay.git
37
+
$ opam update
38
+
$ opam install claude
23
39
```
24
40
25
41
## Usage
26
42
43
+
### Basic query
44
+
27
45
```ocaml
28
-
open Eio
29
-
open Claudeio
46
+
let () =
47
+
Eio_main.run @@ fun env ->
48
+
Eio.Switch.run @@ fun sw ->
49
+
let process_mgr = Eio.Stdenv.process_mgr env in
50
+
let clock = Eio.Stdenv.clock env in
51
+
let client = Client.v ~sw ~process_mgr ~clock () in
52
+
Client.query client "What is 2+2?";
53
+
let messages = Client.receive_all client in
54
+
List.iter
55
+
(function
56
+
| Message.Assistant msg ->
57
+
Printf.printf "Claude: %s\n" (Message.Assistant.text msg)
58
+
| _ -> ())
59
+
messages
60
+
```
30
61
31
-
let main ~env =
32
-
let claude = Claude.create ~env in
33
-
Claude.query claude ~prompt:"Your question here"
34
-
|> Seq.iter (fun response ->
35
-
Format.printf "Claude: %s\n" (Claude.Response.to_string response))
62
+
### Streaming responses
63
+
64
+
```ocaml
65
+
let () =
66
+
Eio_main.run @@ fun env ->
67
+
Eio.Switch.run @@ fun sw ->
68
+
let process_mgr = Eio.Stdenv.process_mgr env in
69
+
let clock = Eio.Stdenv.clock env in
70
+
let client = Client.v ~sw ~process_mgr ~clock () in
71
+
Client.query client "Explain OCaml modules";
72
+
Client.receive client
73
+
|> Seq.iter (function
74
+
| Message.Assistant a -> print_string (Message.Assistant.text a)
75
+
| _ -> ())
36
76
```
37
77
38
-
## Known Issues
78
+
### With custom handler
39
79
40
-
⚠️ **Permissions Support**: The permissions functionality is temporarily broken and awaiting a fix from Anthropic. This feature will be restored in a future update.
80
+
```ocaml
81
+
let () =
82
+
Eio_main.run @@ fun env ->
83
+
Eio.Switch.run @@ fun sw ->
84
+
let process_mgr = Eio.Stdenv.process_mgr env in
85
+
let clock = Eio.Stdenv.clock env in
86
+
let handler =
87
+
Handler.default
88
+
~on_text:(fun _client text -> print_string text)
89
+
~on_tool_use:(fun _client tool ->
90
+
Fmt.pr "Tool: %s\n" (Response.Tool_use.name tool))
91
+
()
92
+
in
93
+
let client = Client.v ~sw ~process_mgr ~clock () in
94
+
Client.run client ~handler "Summarize this project"
95
+
```
41
96
42
97
## Requirements
43
98
44
-
- OCaml >= 5.0
45
-
- Eio >= 1.0
46
-
- Ezjsonm >= 1.3
99
+
- OCaml >= 5.1
100
+
- Eio, Jsont, Cmdliner, Bytesrw
47
101
- Claude Code CLI installed and configured
48
102
49
-
## License
103
+
## Licence
50
104
51
-
See LICENSE file for details.
105
+
ISC
+6
-2
claude.opam
+6
-2
claude.opam
···
6
6
maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
7
7
authors: ["Anil Madhavapeddy"]
8
8
license: "ISC"
9
+
tags: ["org:blacksun" "cli"]
9
10
homepage: "https://tangled.org/anil.recoil.org/ocaml-claudeio"
10
11
bug-reports: "https://tangled.org/anil.recoil.org/ocaml-claudeio/issues"
11
12
depends: [
···
16
17
"fmt"
17
18
"logs"
18
19
"cmdliner"
19
-
"bytesrw"
20
-
"jsont" {>= "0.2.0"}
20
+
"nox-json" {>= "0.2.0"}
21
21
"odoc" {with-doc}
22
22
"alcotest" {with-test & >= "1.7.0"}
23
+
"mdx" {with-test}
24
+
"nox-loc"
23
25
]
24
26
build: [
25
27
["dune" "subst"] {dev}
···
37
39
]
38
40
dev-repo: "git+https://tangled.org/anil.recoil.org/ocaml-claudeio"
39
41
x-maintenance-intent: ["(latest)"]
42
+
x-quality-build: "2026-04-15"
43
+
x-quality-test: "2026-04-15"
+8
dune
+8
dune
+6
-3
dune-project
+6
-3
dune-project
···
1
1
(lang dune 3.21)
2
+
(using mdx 0.4)
2
3
(name claude)
3
4
4
5
(generate_opam_files true)
···
11
12
(package
12
13
(name claude)
13
14
(synopsis "OCaml client library for Claude Code")
15
+
(tags (org:blacksun cli))
14
16
(description "An Eio-based OCaml library for interacting with the Claude CLI using JSON streaming")
15
17
(depends
16
18
(ocaml (>= 5.1.0))
···
19
21
fmt
20
22
logs
21
23
cmdliner
22
-
bytesrw
23
-
(jsont (>= 0.2.0))
24
+
(nox-json (>= 0.2.0))
24
25
(odoc :with-doc)
25
-
(alcotest (and :with-test (>= 1.7.0)))))
26
+
(alcotest (and :with-test (>= 1.7.0)))
27
+
(mdx :with-test)
28
+
nox-loc))
+36
examples/README.md
+36
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
+
<!-- $MDX non-deterministic=command -->
18
+
```sh
19
+
$ # Run the camel joke competition
20
+
$ dune exec camel_jokes
21
+
22
+
$ # Run the permission demo (interactive)
23
+
$ dune exec permission_demo
24
+
25
+
$ # With verbose output to see message flow
26
+
$ dune exec permission_demo -- -v
27
+
```
28
+
29
+
## Features Tested
30
+
31
+
- Concurrent Claude client instances
32
+
- Message handling and processing
33
+
- Permission callbacks
34
+
- Tool access control
35
+
- Typed message API
36
+
- 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))
+103
examples/dune
+103
examples/dune
···
1
+
(library
2
+
(name json_utils)
3
+
(modules json_utils)
4
+
(libraries nox-json))
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 fmt))
96
+
97
+
(executable
98
+
(name structured_error_demo)
99
+
(modules structured_error_demo)
100
+
(libraries claude eio_main fmt))
101
+
102
+
(mdx
103
+
(files README.md))
+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 Json.of_string Claude.Incoming.json 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" (Json.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 Json.of_string Claude.Incoming.json 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
+
(Json.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 Json.of_string Claude.Incoming.json 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
+
(Json.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 Json.of_string Claude.Incoming.json 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
+
(Json.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 Json.of_string Claude.Incoming.json 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
+
(Json.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!"
+27
examples/json_utils.ml
+27
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
+
let to_string ?(minify = false) json =
7
+
let indent = if minify then None else Some 2 in
8
+
Json.Value.to_string ?indent json
9
+
10
+
let find (type a) (codec : a Json.codec) json key : a option =
11
+
let field_codec =
12
+
let open Json.Codec in
13
+
Object.map ~kind:"field" (fun v -> v)
14
+
|> Object.opt_member key codec ~enc:Fun.id
15
+
|> Object.seal
16
+
in
17
+
match Json.decode field_codec json with Ok v -> v | Error _ -> None
18
+
19
+
let string json key = find Json.Codec.string json key
20
+
let int json key = find Json.Codec.int json key
21
+
let bool json key = find Json.Codec.bool json key
22
+
let array json key = find (Json.Codec.list Json.Codec.Value.t) json key
23
+
24
+
let as_string json =
25
+
match Json.decode Json.Codec.string json with
26
+
| Ok s -> Some s
27
+
| 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 json codecs. *)
7
+
8
+
val to_string : ?minify:bool -> Json.t -> string
9
+
(** Encode JSON to string. *)
10
+
11
+
val string : Json.t -> string -> string option
12
+
(** [string json key] extracts a string field. *)
13
+
14
+
val int : Json.t -> string -> int option
15
+
(** [int json key] extracts an integer field. *)
16
+
17
+
val bool : Json.t -> string -> bool option
18
+
(** [bool json key] extracts a boolean field. *)
19
+
20
+
val array : Json.t -> string -> Json.t list option
21
+
(** [array json key] extracts an array field. *)
22
+
23
+
val as_string : Json.t -> 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
+137
examples/simple_permission_test.ml
+137
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
+
Log.app (fun m -> m " %s" (Json.Value.to_string json))
50
+
| None -> ()
51
+
end
52
+
| Claude.Response.Complete result ->
53
+
Log.app (fun m -> m "\n✅ Success!");
54
+
(match Claude.Response.Complete.total_cost_usd result with
55
+
| Some cost -> Log.app (fun m -> m "💰 Cost: $%.6f" cost)
56
+
| None -> ());
57
+
Log.app (fun m ->
58
+
m "⏱️ Duration: %dms"
59
+
(Claude.Response.Complete.duration_ms result))
60
+
| Claude.Response.Error err ->
61
+
Log.err (fun m ->
62
+
m "\n❌ Error: %s" (Claude.Response.Error.message err))
63
+
| _ -> ())
64
+
messages;
65
+
66
+
(!tool_count, !write_used)
67
+
68
+
let run_test ~sw ~env =
69
+
Log.app (fun m -> m "🧪 Testing Permission Callbacks (Auto-Allow Mode)");
70
+
Log.app (fun m -> m "====================================================");
71
+
72
+
(* Create options with permission callback *)
73
+
let options =
74
+
Claude.Options.default
75
+
|> Claude.Options.with_model (Claude.Model.of_string "sonnet")
76
+
|> Claude.Options.with_permission_callback auto_allow_callback
77
+
in
78
+
79
+
Log.app (fun m -> m "Creating client with permission callback...");
80
+
let client =
81
+
Claude.Client.v ~options ~sw ~process_mgr:env#process_mgr ~clock:env#clock
82
+
()
83
+
in
84
+
85
+
(* Query that should trigger Write tool *)
86
+
Log.app (fun m -> m "\n📤 Asking Claude to write a file...");
87
+
Claude.Client.query client
88
+
"Write a simple hello world message to /tmp/test_permission.txt";
89
+
90
+
(* Process response *)
91
+
let messages = Claude.Client.receive_all client in
92
+
Log.app (fun m -> m "\n📨 Received %d messages" (List.length messages));
93
+
94
+
let tool_count, write_used = process_test_responses messages in
95
+
96
+
Log.app (fun m -> m "\n====================================================");
97
+
Log.app (fun m -> m "📊 Test Results:");
98
+
Log.app (fun m -> m " Total tools used: %d" tool_count);
99
+
Log.app (fun m -> m " Write tool used: %b" write_used);
100
+
101
+
if write_used then
102
+
Log.app (fun m ->
103
+
m " ✅ Permission callback successfully intercepted Write tool!")
104
+
else Log.app (fun m -> m " ⚠️ Write tool was not used (unexpected)");
105
+
106
+
Log.app (fun m -> m "====================================================");
107
+
Log.app (fun m -> m "✨ Test complete!")
108
+
109
+
let main ~env = Switch.run @@ fun sw -> run_test ~sw ~env
110
+
111
+
(* Command-line interface *)
112
+
open Cmdliner
113
+
114
+
let main_term env =
115
+
let setup_log style_renderer level =
116
+
Fmt_tty.setup_std_outputs ?style_renderer ();
117
+
Logs.set_level level;
118
+
Logs.set_reporter (Logs_fmt.reporter ());
119
+
if level = None then Logs.set_level (Some Logs.App);
120
+
match level with
121
+
| Some Logs.Info | Some Logs.Debug ->
122
+
Logs.Src.set_level Claude.Client.src (Some Logs.Info);
123
+
Logs.Src.set_level Claude.Transport.src (Some Logs.Info)
124
+
| _ -> ()
125
+
in
126
+
let run style level =
127
+
setup_log style level;
128
+
main ~env
129
+
in
130
+
Term.(const run $ Fmt_cli.style_renderer () $ Logs_cli.level ())
131
+
132
+
let cmd env =
133
+
let doc = "Test permission callback with auto-allow" in
134
+
let info = Cmd.info "simple_permission_test" ~version:"1.0" ~doc in
135
+
Cmd.v info (main_term env)
136
+
137
+
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
+223
examples/simulated_permissions.ml
+223
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
+
Json.Value.object'
111
+
[
112
+
Json.Value.member
113
+
(Json.Value.name "file_path")
114
+
(Json.Value.string "/example/path.txt");
115
+
]
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 obj k v =
149
+
Json.Value.object'
150
+
[ Json.Value.member (Json.Value.name k) (Json.Value.string v) ]
151
+
in
152
+
let requests =
153
+
[
154
+
("Read", obj "file_path" "test.ml");
155
+
("Bash", obj "command" "ls -la");
156
+
("Write", obj "file_path" "output.txt");
157
+
]
158
+
in
159
+
160
+
Log.app (fun m -> m "Simulating tool requests with discovery callback...\n");
161
+
162
+
List.iter
163
+
(fun (tool_name, input) ->
164
+
Log.app (fun m -> m " Request: %s" tool_name);
165
+
let tool_input = Claude.Tool_input.of_json input in
166
+
let ctx =
167
+
Claude.Permissions.
168
+
{ tool_name; input = tool_input; suggested_rules = [] }
169
+
in
170
+
let _ = callback ctx in
171
+
())
172
+
requests;
173
+
174
+
Log.app (fun m -> m "\n📋 Discovered permissions:");
175
+
if !discovered = [] then Log.app (fun m -> m " None")
176
+
else
177
+
List.iter
178
+
(fun rule ->
179
+
Log.app (fun m ->
180
+
m " - %s%s"
181
+
(Claude.Permissions.Rule.tool_name rule)
182
+
(match Claude.Permissions.Rule.rule_content rule with
183
+
| Some content -> Fmt.str " (content: %s)" content
184
+
| None -> "")))
185
+
!discovered
186
+
187
+
let main () =
188
+
demo_permissions ();
189
+
demo_discovery ()
190
+
191
+
(* Command-line interface *)
192
+
open Cmdliner
193
+
194
+
let main_term =
195
+
let setup_log style_renderer level =
196
+
Fmt_tty.setup_std_outputs ?style_renderer ();
197
+
Logs.set_level level;
198
+
Logs.set_reporter (Logs_fmt.reporter ());
199
+
if level = None then Logs.set_level (Some Logs.App)
200
+
in
201
+
let run style level =
202
+
setup_log style level;
203
+
main ()
204
+
in
205
+
Term.(const run $ Fmt_cli.style_renderer () $ Logs_cli.level ())
206
+
207
+
let cmd =
208
+
let doc = "Demonstrate permission callbacks and discovery" in
209
+
let man =
210
+
[
211
+
`S Manpage.s_description;
212
+
`P
213
+
"This program demonstrates how permission callbacks work in the Claude \
214
+
OCaml library.";
215
+
`P
216
+
"It simulates permission requests and shows how to implement custom \
217
+
callbacks.";
218
+
]
219
+
in
220
+
let info = Cmd.info "simulated_permissions" ~version:"1.0" ~doc ~man in
221
+
Cmd.v info main_term
222
+
223
+
let () = exit (Cmd.eval cmd)
+265
examples/structured_error_demo.ml
+265
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
+
let json = Json.encode Claude.Control.Response.json error_resp in
33
+
let json_str = Json.Value.to_string json in
34
+
Fmt.pr "✓ Encoded error response: %s\n" json_str;
35
+
36
+
(* Decode it back *)
37
+
match Json.decode Claude.Control.Response.json json with
38
+
| Ok (Claude.Control.Response.Error decoded) ->
39
+
Fmt.pr "✓ Decoded error: [%d] %s\n" decoded.error.code
40
+
decoded.error.message
41
+
| Ok _ -> print_endline "✗ Wrong response type"
42
+
| Error e -> Fmt.pr "✗ Decode failed: %s\n" (Json.Error.to_string e)
43
+
44
+
let test_error_code_conventions () =
45
+
print_endline "\nTesting JSON-RPC error code conventions...";
46
+
47
+
(* Standard JSON-RPC errors using the typed API with polymorphic variants *)
48
+
let errors =
49
+
[
50
+
(`Parse_error, "Parse error");
51
+
(`Invalid_request, "Invalid request");
52
+
(`Method_not_found, "Method not found");
53
+
(`Invalid_params, "Invalid params");
54
+
(`Internal_error, "Internal error");
55
+
(`Custom 1, "Application error");
56
+
]
57
+
in
58
+
59
+
List.iter
60
+
(fun (code, msg) ->
61
+
let err = Claude.Control.Response.error_detail ~code ~message:msg () in
62
+
Fmt.pr "✓ Error [%d]: %s (typed)\n" err.code err.message)
63
+
errors
64
+
65
+
let process_error_responses messages =
66
+
let error_found = ref false in
67
+
let text_error_found = ref false in
68
+
List.iter
69
+
(fun resp ->
70
+
match resp with
71
+
| Claude.Response.Error err ->
72
+
error_found := true;
73
+
Fmt.pr "✓ Received structured error response: %s\n"
74
+
(Claude.Response.Error.message err);
75
+
Fmt.pr " Is system error: %b\n"
76
+
(Claude.Response.Error.is_system_error err);
77
+
Fmt.pr " Is assistant error: %b\n"
78
+
(Claude.Response.Error.is_assistant_error err)
79
+
| Claude.Response.Text text ->
80
+
let content = Claude.Response.Text.content text in
81
+
if
82
+
String.length content > 0
83
+
&& (String.contains content '4' || String.contains content 'e')
84
+
then begin
85
+
text_error_found := true;
86
+
Fmt.pr "✓ Received error as text: %s\n" content
87
+
end
88
+
| Claude.Response.Complete result ->
89
+
Fmt.pr " Complete (duration: %dms)\n"
90
+
(Claude.Response.Complete.duration_ms result)
91
+
| _ -> ())
92
+
messages;
93
+
94
+
if !error_found then
95
+
Fmt.pr "✓ Successfully caught structured error response\n"
96
+
else if !text_error_found then
97
+
Fmt.pr "✓ Successfully caught error (returned as text)\n"
98
+
else Fmt.pr "✗ No error was returned (unexpected)\n"
99
+
100
+
let test_provoke_api_error ~sw ~env =
101
+
print_endline "\nTesting API error from Claude...";
102
+
103
+
(* Configure client with an invalid model to provoke an API error *)
104
+
let options =
105
+
Claude.Options.default
106
+
|> Claude.Options.with_model
107
+
(Claude.Model.of_string "invalid-model-that-does-not-exist")
108
+
in
109
+
110
+
Fmt.pr "Creating client with invalid model...\n";
111
+
112
+
try
113
+
let client =
114
+
Claude.Client.v ~options ~sw ~process_mgr:env#process_mgr ~clock:env#clock
115
+
()
116
+
in
117
+
118
+
Fmt.pr "Sending query to provoke API error...\n";
119
+
Claude.Client.query client
120
+
"Hello, this should fail with an invalid model error";
121
+
122
+
(* Process responses to see if we get an error *)
123
+
let messages = Claude.Client.receive_all client in
124
+
process_error_responses messages
125
+
with
126
+
| Claude.Transport.Connection_error msg ->
127
+
Fmt.pr "✓ Connection error as expected: %s\n" msg
128
+
| exn ->
129
+
Fmt.pr "✗ Unexpected exception: %s\n" (Printexc.to_string exn);
130
+
Printexc.print_backtrace stdout
131
+
132
+
let test_control_protocol_error () =
133
+
print_endline "\nTesting control protocol error encoding/decoding...";
134
+
135
+
(* Test that we can create and encode a control protocol error using polymorphic variant codes *)
136
+
let error_detail =
137
+
Claude.Control.Response.error_detail ~code:`Invalid_params
138
+
~message:"Invalid params for permission request"
139
+
~data:
140
+
(Json.Value.object'
141
+
[
142
+
Json.Value.member
143
+
(Json.Value.name "tool_name")
144
+
(Json.Value.string "Write");
145
+
Json.Value.member (Json.Value.name "reason")
146
+
(Json.Value.string "Missing required file_path parameter");
147
+
])
148
+
()
149
+
in
150
+
151
+
let error_response =
152
+
Claude.Control.Response.error ~request_id:"test-req-456" ~error:error_detail
153
+
()
154
+
in
155
+
156
+
let json = Json.encode Claude.Control.Response.json error_response in
157
+
let json_str = Json.Value.to_string json in
158
+
Fmt.pr "✓ Encoded control error with data:\n %s\n" json_str;
159
+
160
+
(* Verify we can decode it back *)
161
+
match Json.decode Claude.Control.Response.json json with
162
+
| Ok (Claude.Control.Response.Error decoded) -> (
163
+
Fmt.pr "✓ Decoded control error:\n";
164
+
Fmt.pr " Code: %d\n" decoded.error.code;
165
+
Fmt.pr " Message: %s\n" decoded.error.message;
166
+
Fmt.pr " Has data: %b\n" (Option.is_some decoded.error.data);
167
+
match decoded.error.data with
168
+
| Some data -> Fmt.pr " Data: %s\n" (Json.Value.to_string data)
169
+
| None -> ())
170
+
| Ok _ -> print_endline "✗ Wrong response type"
171
+
| Error e -> Fmt.pr "✗ Decode failed: %s\n" (Json.Error.to_string e)
172
+
173
+
let process_hook_responses messages =
174
+
let hook_called = ref false in
175
+
let error_found = ref false in
176
+
List.iter
177
+
(fun resp ->
178
+
match resp with
179
+
| Claude.Response.Tool_use tool ->
180
+
let tool_name = Claude.Response.Tool_use.name tool in
181
+
if tool_name = "Write" then begin
182
+
hook_called := true;
183
+
Fmt.pr "✓ Write tool was called (hook intercepted it)\n"
184
+
end
185
+
| Claude.Response.Error err ->
186
+
error_found := true;
187
+
Fmt.pr " Error response: %s\n" (Claude.Response.Error.message err)
188
+
| Claude.Response.Complete _ -> Fmt.pr " Query completed\n"
189
+
| _ -> ())
190
+
messages;
191
+
192
+
if !hook_called then Fmt.pr "✓ Hook was triggered, exception caught by SDK\n"
193
+
else
194
+
Fmt.pr
195
+
" Note: Hook may not have been called if query didn't use Write tool\n";
196
+
197
+
Fmt.pr "✓ Test completed (SDK sent -32603 Internal Error to CLI)\n"
198
+
199
+
let test_hook_error ~sw ~env =
200
+
print_endline "\nTesting hook callback errors trigger JSON-RPC error codes...";
201
+
202
+
(* Create a hook that will throw an exception *)
203
+
let failing_hook input =
204
+
Fmt.pr "✓ Hook called for tool: %s\n"
205
+
input.Claude.Hooks.Pre_tool_use.tool_name;
206
+
failwith "Intentional hook failure to test error handling"
207
+
in
208
+
209
+
(* Register the failing hook *)
210
+
let hooks =
211
+
Claude.Hooks.empty
212
+
|> Claude.Hooks.on_pre_tool_use ~pattern:"Write" failing_hook
213
+
in
214
+
215
+
let options =
216
+
Claude.Options.default
217
+
|> Claude.Options.with_hooks hooks
218
+
|> Claude.Options.with_model (Claude.Model.of_string "haiku")
219
+
in
220
+
221
+
Fmt.pr "Creating client with failing hook...\n";
222
+
223
+
try
224
+
let client =
225
+
Claude.Client.v ~options ~sw ~process_mgr:env#process_mgr ~clock:env#clock
226
+
()
227
+
in
228
+
229
+
Fmt.pr "Asking Claude to write a file (should trigger failing hook)...\n";
230
+
Claude.Client.query client "Write 'test' to /tmp/test_hook_error.txt";
231
+
232
+
(* Process responses *)
233
+
let messages = Claude.Client.receive_all client in
234
+
process_hook_responses messages
235
+
with exn ->
236
+
Fmt.pr "Exception during test: %s\n" (Printexc.to_string exn);
237
+
Printexc.print_backtrace stdout
238
+
239
+
let run_all_tests env =
240
+
print_endline "=== Structured Error Tests ===";
241
+
test_create_error_detail ();
242
+
test_error_code_conventions ();
243
+
test_control_protocol_error ();
244
+
245
+
(* Test with actual Claude invocation *)
246
+
Switch.run @@ fun sw ->
247
+
test_provoke_api_error ~sw ~env;
248
+
249
+
(* Test hook errors that trigger JSON-RPC error codes *)
250
+
Switch.run @@ fun sw ->
251
+
test_hook_error ~sw ~env;
252
+
253
+
print_endline "\n=== All Structured Error Tests Completed ==="
254
+
255
+
let () =
256
+
Eio_main.run @@ fun env ->
257
+
try run_all_tests env with
258
+
| Claude.Transport.CLI_not_found msg ->
259
+
Fmt.epr "Error: Claude CLI not found\n%s\n" msg;
260
+
Fmt.epr "Make sure 'claude' is installed and in your PATH\n";
261
+
exit 1
262
+
| exn ->
263
+
Fmt.epr "Fatal error: %s\n" (Printexc.to_string exn);
264
+
Printexc.print_backtrace stderr;
265
+
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
+
Json.Value.object'
18
+
[
19
+
Json.Value.member (Json.Value.name "type") (Json.Value.string typ);
20
+
Json.Value.member (Json.Value.name "description") (Json.Value.string desc);
21
+
]
22
+
23
+
let complexity_rating_prop =
24
+
Json.Value.object'
25
+
[
26
+
Json.Value.member (Json.Value.name "type") (Json.Value.string "string");
27
+
Json.Value.member (Json.Value.name "enum")
28
+
(Json.Value.list
29
+
[
30
+
Json.Value.string "low";
31
+
Json.Value.string "medium";
32
+
Json.Value.string "high";
33
+
]);
34
+
Json.Value.member
35
+
(Json.Value.name "description")
36
+
(Json.Value.string "Overall complexity rating");
37
+
]
38
+
39
+
let key_findings_prop =
40
+
Json.Value.object'
41
+
[
42
+
Json.Value.member (Json.Value.name "type") (Json.Value.string "array");
43
+
Json.Value.member (Json.Value.name "items")
44
+
(Json.Value.object'
45
+
[
46
+
Json.Value.member (Json.Value.name "type")
47
+
(Json.Value.string "string");
48
+
]);
49
+
Json.Value.member
50
+
(Json.Value.name "description")
51
+
(Json.Value.string "List of key findings from the analysis");
52
+
]
53
+
54
+
let analysis_properties =
55
+
Json.Value.object'
56
+
[
57
+
Json.Value.member
58
+
(Json.Value.name "file_count")
59
+
(typed_prop "integer" "Total number of files analyzed");
60
+
Json.Value.member
61
+
(Json.Value.name "has_tests")
62
+
(typed_prop "boolean" "Whether the codebase has test files");
63
+
Json.Value.member
64
+
(Json.Value.name "primary_language")
65
+
(typed_prop "string" "The primary programming language used");
66
+
Json.Value.member
67
+
(Json.Value.name "complexity_rating")
68
+
complexity_rating_prop;
69
+
Json.Value.member (Json.Value.name "key_findings") key_findings_prop;
70
+
]
71
+
72
+
let analysis_schema =
73
+
Json.Value.object'
74
+
[
75
+
Json.Value.member (Json.Value.name "type") (Json.Value.string "object");
76
+
Json.Value.member (Json.Value.name "properties") analysis_properties;
77
+
Json.Value.member
78
+
(Json.Value.name "required")
79
+
(Json.Value.list
80
+
[
81
+
Json.Value.string "file_count";
82
+
Json.Value.string "has_tests";
83
+
Json.Value.string "primary_language";
84
+
Json.Value.string "complexity_rating";
85
+
Json.Value.string "key_findings";
86
+
]);
87
+
Json.Value.member
88
+
(Json.Value.name "additionalProperties")
89
+
(Json.Value.bool false);
90
+
]
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
+82
examples/structured_output_simple.ml
+82
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 typ t =
16
+
Json.Value.object'
17
+
[ Json.Value.member (Json.Value.name "type") (Json.Value.string t) ]
18
+
in
19
+
Json.Value.object'
20
+
[
21
+
Json.Value.member (Json.Value.name "type") (Json.Value.string "object");
22
+
Json.Value.member
23
+
(Json.Value.name "properties")
24
+
(Json.Value.object'
25
+
[
26
+
Json.Value.member (Json.Value.name "name") (typ "string");
27
+
Json.Value.member (Json.Value.name "age") (typ "integer");
28
+
Json.Value.member (Json.Value.name "occupation") (typ "string");
29
+
]);
30
+
Json.Value.member
31
+
(Json.Value.name "required")
32
+
(Json.Value.list
33
+
[
34
+
Json.Value.string "name";
35
+
Json.Value.string "age";
36
+
Json.Value.string "occupation";
37
+
]);
38
+
]
39
+
40
+
let simple_example env =
41
+
Fmt.pr "\n=== Simple Structured Output Example ===\n\n";
42
+
43
+
let output_format = Claude.Structured_output.of_json_schema person_schema in
44
+
45
+
let options =
46
+
C.Options.default
47
+
|> C.Options.with_output_format output_format
48
+
|> C.Options.with_max_turns 1
49
+
in
50
+
51
+
Fmt.pr "Asking Claude to provide structured data...\n\n";
52
+
53
+
Eio.Switch.run @@ fun sw ->
54
+
let process_mgr = Eio.Stdenv.process_mgr env in
55
+
let clock = Eio.Stdenv.clock env in
56
+
let client = C.Client.v ~sw ~process_mgr ~clock ~options () in
57
+
58
+
C.Client.query client
59
+
"Tell me about a famous computer scientist. Provide their name, age, and \
60
+
occupation in the exact JSON structure I specified.";
61
+
62
+
let responses = C.Client.receive_all client in
63
+
List.iter
64
+
(function
65
+
| C.Response.Complete result -> (
66
+
Fmt.pr "Response received!\n";
67
+
match C.Response.Complete.structured_output result with
68
+
| Some json ->
69
+
Fmt.pr "\nStructured Output:\n%s\n"
70
+
(Json_utils.to_string ~minify:false json)
71
+
| None -> Fmt.pr "No structured output\n")
72
+
| C.Response.Error err ->
73
+
Fmt.pr "Error: %s\n" (C.Response.Error.message err)
74
+
| _ -> ())
75
+
responses
76
+
77
+
let () =
78
+
Eio_main.run @@ fun env ->
79
+
try simple_example env
80
+
with exn ->
81
+
Fmt.epr "Error: %s\n" (Printexc.to_string exn);
82
+
exit 1
+5
-2
lib/claude.ml
+5
-2
lib/claude.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
module Err = Err
6
+
module Error = Error
7
7
module Client = Client
8
8
module Options = Options
9
9
module Response = Response
10
10
module Handler = Handler
11
11
module Tool_input = Tool_input
12
12
module Content_block = Content_block
13
+
module Incoming = Incoming
13
14
module Message = Message
14
15
module Permissions = Permissions
15
16
module Hooks = Hooks
16
17
module Server_info = Server_info
17
18
module Transport = Transport
18
19
module Model = Model
19
-
module Proto = Proto
20
20
module Structured_output = Structured_output
21
+
module Control = Control
22
+
module Outgoing = Outgoing
23
+
module Unknown = Unknown
21
24
22
25
(* New MCP-based custom tool support *)
23
26
module Tool = Tool
+97
-99
lib/claude.mli
+97
-99
lib/claude.mli
···
37
37
- {!Tool_input}: Opaque tool input with typed accessors
38
38
- {!Server_info}: Server capabilities and metadata
39
39
40
-
{2 Wire Format (Advanced)}
41
-
- {!Proto}: Direct access to wire-format types and JSON codecs
42
-
43
40
{1 Quick Start}
44
41
45
42
{[
46
-
open Eio.Std
43
+
open Eio.Std
47
44
48
-
let () =
49
-
Eio_main.run @@ fun env ->
50
-
Switch.run @@ fun sw ->
51
-
let client =
52
-
Claude.Client.create ~sw ~process_mgr:(Eio.Stdenv.process_mgr env) ()
53
-
in
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
54
51
55
-
Claude.Client.query client "What is 2+2?";
52
+
Claude.Client.query client "What is 2+2?";
56
53
57
-
let handler =
58
-
object
59
-
inherit Claude.Handler.default
60
-
method! on_text t = print_endline (Claude.Response.Text.content t)
61
-
end
62
-
in
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
63
60
64
-
Claude.Client.run client ~handler
61
+
Claude.Client.run client ~handler
65
62
]}
66
63
67
64
{1 Response Handling}
···
73
70
Subclass {!Handler.default} and override only the methods you need:
74
71
75
72
{[
76
-
let my_handler =
77
-
object
78
-
inherit Claude.Handler.default
79
-
method! on_text t = print_endline (Claude.Response.Text.content t)
73
+
let my_handler =
74
+
object
75
+
inherit Claude.Handler.default
76
+
method! on_text t = print_endline (Claude.Response.Text.content t)
80
77
81
-
method! on_tool_use t =
82
-
Printf.printf "Tool: %s\n" (Claude.Response.Tool_use.name t)
78
+
method! on_tool_use t =
79
+
Printf.printf "Tool: %s\n" (Claude.Response.Tool_use.name t)
83
80
84
-
method! on_complete c =
85
-
Printf.printf "Done! Cost: $%.4f\n"
86
-
(Option.value ~default:0.0
87
-
(Claude.Response.Complete.total_cost_usd c))
88
-
end
89
-
in
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
90
87
91
-
Claude.Client.run client ~handler:my_handler
88
+
Claude.Client.run client ~handler:my_handler
92
89
]}
93
90
94
91
{2 Functional Sequence}
···
96
93
For more control, use {!Client.receive} to get a lazy sequence:
97
94
98
95
{[
99
-
Claude.Client.receive client
100
-
|> Seq.iter (function
101
-
| Claude.Response.Text t ->
102
-
print_endline (Claude.Response.Text.content t)
103
-
| Claude.Response.Complete c -> Printf.printf "Done!\n"
104
-
| _ -> ())
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
+
| _ -> ())
105
101
]}
106
102
107
103
{1 Tool Permissions}
···
109
105
Control which tools Claude can use:
110
106
111
107
{[
112
-
let options =
113
-
Claude.Options.default
114
-
|> Claude.Options.with_allowed_tools [ "Read"; "Write"; "Bash" ]
115
-
|> Claude.Options.with_permission_mode
116
-
Claude.Permissions.Mode.Accept_edits
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
117
113
]}
118
114
119
115
{2 Custom Permission Callbacks}
···
121
117
Implement custom logic for tool approval:
122
118
123
119
{[
124
-
let my_callback ctx =
125
-
if ctx.Claude.Permissions.tool_name = "Bash" then
126
-
Claude.Permissions.Decision.deny ~message:"Bash not allowed"
127
-
~interrupt:false
128
-
else Claude.Permissions.Decision.allow ()
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 ()
129
125
130
-
let options =
131
-
Claude.Options.default
132
-
|> Claude.Options.with_permission_callback my_callback
126
+
let options =
127
+
Claude.Options.default
128
+
|> Claude.Options.with_permission_callback my_callback
133
129
]}
134
130
135
131
{1 Typed Hooks}
···
137
133
Intercept and control tool execution with fully typed callbacks:
138
134
139
135
{[
140
-
let hooks =
141
-
Claude.Hooks.empty
142
-
|> Claude.Hooks.on_pre_tool_use ~pattern:"Bash" (fun input ->
143
-
if
144
-
String.is_prefix ~prefix:"rm"
145
-
(input.tool_input
146
-
|> Claude.Tool_input.get_string "command"
147
-
|> Option.value ~default:"")
148
-
then Claude.Hooks.PreToolUse.deny ~reason:"Dangerous command" ()
149
-
else Claude.Hooks.PreToolUse.continue ())
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 ())
150
146
151
-
let options = Claude.Options.default |> Claude.Options.with_hooks hooks
147
+
let options = Claude.Options.default |> Claude.Options.with_hooks hooks
152
148
]}
153
149
154
150
{1 Error Handling}
155
151
156
-
The library uses a structured exception type {!Err.E} for all errors:
152
+
The library uses a structured exception type {!Error.E} for all errors:
157
153
158
154
{[
159
-
try Claude.Client.query client "Hello"
160
-
with Claude.Err.E err ->
161
-
Printf.eprintf "Error: %s\n" (Claude.Err.to_string err)
155
+
try Claude.Client.query client "Hello"
156
+
with Claude.Error.E err ->
157
+
Printf.eprintf "Error: %s\n" (Claude.Error.to_string err)
162
158
]}
163
159
164
160
Error types include:
165
-
- {!Err.Cli_not_found}: Claude CLI not found
166
-
- {!Err.Process_error}: Process execution failure
167
-
- {!Err.Protocol_error}: JSON/protocol parsing error
168
-
- {!Err.Timeout}: Operation timed out
169
-
- {!Err.Permission_denied}: Tool permission denied
170
-
- {!Err.Hook_error}: Hook callback error
161
+
- {!Error.Cli_not_found}: Claude CLI not found
162
+
- {!Error.Process_error}: Process execution failure
163
+
- {!Error.Protocol_error}: JSON/protocol parsing error
164
+
- {!Error.Timeout}: Operation timed out
165
+
- {!Error.Permission_denied}: Tool permission denied
166
+
- {!Error.Hook_error}: Hook callback error
171
167
172
168
{1 Logging}
173
169
···
175
171
its own log source allowing fine-grained control:
176
172
177
173
{[
178
-
Logs.Src.set_level Claude.Client.src (Some Logs.Debug);
179
-
Logs.Src.set_level Claude.Transport.src (Some Logs.Info)
174
+
Logs.Src.set_level Claude.Client.src (Some Logs.Debug);
175
+
Logs.Src.set_level Claude.Transport.src (Some Logs.Info)
180
176
]} *)
181
177
182
178
(** {1 Core Modules} *)
183
179
184
-
module Err = Err
180
+
module Error = Error
185
181
(** Error handling with structured exception type. *)
186
182
187
183
module Client = Client
···
203
199
204
200
module Content_block = Content_block
205
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). *)
206
205
207
206
module Message = Message
208
207
(** Messages exchanged with Claude (user, assistant, system, result). *)
···
222
221
module Structured_output = Structured_output
223
222
(** Structured output configuration using JSON Schema. *)
224
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
+
225
233
(** {1 Custom Tools (MCP)}
226
234
227
235
These modules enable custom tool definitions that run in-process via MCP
···
231
239
{2 Example}
232
240
233
241
{[
234
-
let greet =
235
-
Claude.Tool.create ~name:"greet" ~description:"Greet a user"
236
-
~input_schema:
237
-
(Claude.Tool.schema_object
238
-
[ ("name", Claude.Tool.schema_string) ]
239
-
~required:[ "name" ])
240
-
~handler:(fun args ->
241
-
match Claude.Tool_input.get_string args "name" with
242
-
| Some name -> Ok (Claude.Tool.text_result ("Hello, " ^ name ^ "!"))
243
-
| None -> Error "Missing name")
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")
244
252
245
-
let server = Claude.Mcp_server.create ~name:"my-tools" ~tools:[ greet ] ()
253
+
let server = Claude.Mcp_server.v ~name:"my-tools" ~tools:[ greet ] ()
246
254
247
-
let options =
248
-
Claude.Options.default
249
-
|> Claude.Options.with_mcp_server ~name:"tools" server
250
-
|> Claude.Options.with_allowed_tools [ "mcp__tools__greet" ]
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" ]
251
259
]} *)
252
260
253
261
module Tool = Tool
···
260
268
261
269
module Transport = Transport
262
270
(** Low-level transport layer for CLI communication. *)
263
-
264
-
(** {1 Wire Format (Advanced)}
265
-
266
-
The {!Proto} module provides direct access to wire-format types and JSON
267
-
codecs. Use this for advanced scenarios like custom transports or debugging.
268
-
269
-
Most users should use the high-level types above instead. *)
270
-
271
-
module Proto = Proto
272
-
(** Wire-format types and JSON codecs. *)
+222
-259
lib/client.ml
+222
-259
lib/client.ml
···
7
7
8
8
module Log = (val Logs.src_log src : Logs.LOG)
9
9
10
-
(** Control response builders using Sdk_control codecs *)
10
+
let encode_or_raise ~msg:_ codec v = Json.encode codec v
11
+
12
+
(** Control response builders using Control codecs *)
11
13
module Control_response = struct
12
14
let success ~request_id ~response =
13
-
let resp = Sdk_control.Response.success ~request_id ?response () in
14
-
let ctrl = Sdk_control.create_response ~response:resp () in
15
-
Jsont.Json.encode Sdk_control.jsont ctrl
16
-
|> Err.get_ok ~msg:"Control_response.success: "
15
+
let resp = Control.Response.success ~request_id ?response () in
16
+
let ctrl = Control.response ~response:resp () in
17
+
encode_or_raise ~msg:"Control_response.success: " Control.json ctrl
17
18
18
19
let error ~request_id ~code ~message ?data () =
19
-
let error_detail =
20
-
Sdk_control.Response.error_detail ~code ~message ?data ()
21
-
in
22
-
let resp = Sdk_control.Response.error ~request_id ~error:error_detail () in
23
-
let ctrl = Sdk_control.create_response ~response:resp () in
24
-
Jsont.Json.encode Sdk_control.jsont ctrl
25
-
|> Err.get_ok ~msg:"Control_response.error: "
20
+
let error_detail = Control.Response.error_detail ~code ~message ?data () in
21
+
let resp = Control.Response.error ~request_id ~error:error_detail () in
22
+
let ctrl = Control.response ~response:resp () in
23
+
encode_or_raise ~msg:"Control_response.error: " Control.json ctrl
26
24
end
27
25
28
-
(* Helper functions for JSON manipulation using jsont *)
29
-
let json_to_string json =
30
-
Jsont_bytesrw.encode_string' Jsont.json json
31
-
|> Result.map_error Jsont.Error.to_string
32
-
|> Err.get_ok ~msg:""
26
+
let json_to_string json = Json.Value.to_string json
33
27
34
28
(** Wire-level codec for hook matcher configuration sent to CLI. *)
35
29
module Hook_matcher_wire = struct
36
30
type t = { matcher : string option; hook_callback_ids : string list }
37
31
38
-
let jsont : t Jsont.t =
32
+
let json : t Json.codec =
33
+
let open Json.Codec in
39
34
let make matcher hook_callback_ids = { matcher; hook_callback_ids } in
40
-
Jsont.Object.map ~kind:"HookMatcherWire" make
41
-
|> Jsont.Object.opt_mem "matcher" Jsont.string ~enc:(fun r -> r.matcher)
42
-
|> Jsont.Object.mem "hookCallbackIds" (Jsont.list Jsont.string)
43
-
~enc:(fun r -> r.hook_callback_ids)
44
-
|> Jsont.Object.finish
35
+
Object.map ~kind:"HookMatcherWire" make
36
+
|> Object.opt_member "matcher" string ~enc:(fun r -> r.matcher)
37
+
|> Object.member "hookCallbackIds" (list string) ~enc:(fun r ->
38
+
r.hook_callback_ids)
39
+
|> Object.seal
45
40
46
41
let encode matchers =
47
-
List.map
48
-
(fun m ->
49
-
Jsont.Json.encode jsont m
50
-
|> Err.get_ok ~msg:"Hook_matcher_wire.encode: ")
51
-
matchers
52
-
|> Jsont.Json.list
42
+
List.map (fun m -> Json.encode json m) matchers |> Json.Value.list
53
43
end
54
44
55
45
type t = {
56
46
transport : Transport.t;
57
47
mutable permission_callback : Permissions.callback option;
58
48
mutable permission_log : Permissions.Rule.t list ref option;
59
-
hook_callbacks : (string, Jsont.json -> Proto.Hooks.result) Hashtbl.t;
49
+
hook_callbacks : (string, Json.t -> Hooks.result) Hashtbl.t;
60
50
mutable session_id : string option;
61
-
control_responses : (string, Jsont.json) Hashtbl.t;
51
+
control_responses : (string, Json.t) Hashtbl.t;
62
52
control_mutex : Eio.Mutex.t;
63
53
control_condition : Eio.Condition.t;
64
54
clock : float Eio.Time.clock_ty Eio.Resource.t;
···
70
60
71
61
let session_id t = t.session_id
72
62
73
-
let handle_control_request t (ctrl_req : Sdk_control.control_request) =
74
-
let request_id = ctrl_req.request_id in
75
-
Log.info (fun m -> m "Handling control request: %s" request_id);
63
+
let handle_permission_request t ~request_id (req : Control.Request.permission) =
64
+
let tool_name = req.tool_name in
65
+
let input_json = req.input in
66
+
Log.info (fun m ->
67
+
m "Permission request for tool '%s' with input: %s" tool_name
68
+
(json_to_string input_json));
69
+
let suggestions = Option.value req.permission_suggestions ~default:[] in
70
+
let suggested_rules =
71
+
Permissions.extract_rules_from_proto_updates suggestions
72
+
in
73
+
74
+
(* Convert input to Tool_input.t *)
75
+
let input = Tool_input.of_json input_json in
76
+
77
+
(* Create context *)
78
+
let context : Permissions.context = { tool_name; input; suggested_rules } in
76
79
77
-
match ctrl_req.request with
78
-
| Sdk_control.Request.Permission req ->
79
-
let tool_name = req.tool_name in
80
-
let input_json = req.input in
81
-
Log.info (fun m ->
82
-
m "Permission request for tool '%s' with input: %s" tool_name
83
-
(json_to_string input_json));
84
-
(* Convert permission_suggestions to suggested rules *)
85
-
let suggestions = Option.value req.permission_suggestions ~default:[] in
86
-
let suggested_rules =
87
-
Permissions.extract_rules_from_proto_updates suggestions
80
+
Log.info (fun m -> m "Invoking permission callback for tool: %s" tool_name);
81
+
let callback =
82
+
Option.value t.permission_callback ~default:Permissions.default_allow
83
+
in
84
+
let decision = callback context in
85
+
Log.info (fun m ->
86
+
m "Permission callback returned: %s"
87
+
(if Permissions.Decision.is_allow decision then "ALLOW" else "DENY"));
88
+
89
+
let lib_result =
90
+
Permissions.Decision.to_proto_result ~original_input:input decision
91
+
in
92
+
let response_data = Json.encode Permissions.Result.json lib_result in
93
+
let response =
94
+
Control_response.success ~request_id ~response:(Some response_data)
95
+
in
96
+
Log.info (fun m -> m "Sending control response: %s" (json_to_string response));
97
+
Transport.send t.transport response
98
+
99
+
let handle_hook_callback t ~request_id (req : Control.Request.hook_callback) =
100
+
let callback_id = req.callback_id in
101
+
let input = req.input in
102
+
let _tool_use_id = req.tool_use_id in
103
+
Log.info (fun m -> m "Hook callback request for callback_id: %s" callback_id);
104
+
105
+
try
106
+
let callback = Hashtbl.find t.hook_callbacks callback_id in
107
+
let result = callback input in
108
+
109
+
let result_json =
110
+
encode_or_raise ~msg:"Failed to encode hook result: " Hooks.result_jsont
111
+
result
112
+
in
113
+
Log.debug (fun m -> m "Hook result JSON: %s" (json_to_string result_json));
114
+
let response =
115
+
Control_response.success ~request_id ~response:(Some result_json)
116
+
in
117
+
Log.info (fun m -> m "Hook callback succeeded, sending response");
118
+
Transport.send t.transport response
119
+
with
120
+
| Not_found ->
121
+
let error_msg = Fmt.str "Hook callback not found: %s" callback_id in
122
+
Log.err (fun m -> m "%s" error_msg);
123
+
Transport.send t.transport
124
+
(Control_response.error ~request_id ~code:`Method_not_found
125
+
~message:error_msg ())
126
+
| exn ->
127
+
let error_msg =
128
+
Fmt.str "Hook callback error: %s" (Printexc.to_string exn)
88
129
in
130
+
Log.err (fun m -> m "%s" error_msg);
131
+
Transport.send t.transport
132
+
(Control_response.error ~request_id ~code:`Internal_error
133
+
~message:error_msg ())
89
134
90
-
(* Convert input to Tool_input.t *)
91
-
let input = Tool_input.of_json input_json in
135
+
let handle_mcp_message t ~request_id (req : Control.Request.mcp_message) =
136
+
let module J = Json.Value in
137
+
let server_name = req.server_name in
138
+
let message = req.message in
139
+
Log.info (fun m -> m "MCP request for server '%s'" server_name);
92
140
93
-
(* Create context *)
94
-
let context : Permissions.context =
95
-
{ tool_name; input; suggested_rules }
141
+
match Hashtbl.find_opt t.mcp_servers server_name with
142
+
| None ->
143
+
let error_msg = Fmt.str "MCP server '%s' not found" server_name in
144
+
Log.err (fun m -> m "%s" error_msg);
145
+
(* Return JSONRPC error in mcp_response format *)
146
+
let mcp_error =
147
+
J.object'
148
+
[
149
+
J.member (J.name "jsonrpc") (J.string "2.0");
150
+
J.member (J.name "id") (J.null ());
151
+
J.member (J.name "error")
152
+
(J.object'
153
+
[
154
+
J.member (J.name "code") (J.number (-32601.0));
155
+
J.member (J.name "message") (J.string error_msg);
156
+
]);
157
+
]
96
158
in
97
-
98
-
Log.info (fun m ->
99
-
m "Invoking permission callback for tool: %s" tool_name);
100
-
let callback =
101
-
Option.value t.permission_callback ~default:Permissions.default_allow
159
+
let response_data =
160
+
J.object' [ J.member (J.name "mcp_response") mcp_error ]
102
161
in
103
-
let decision = callback context in
104
-
Log.info (fun m ->
105
-
m "Permission callback returned: %s"
106
-
(if Permissions.Decision.is_allow decision then "ALLOW" else "DENY"));
107
-
108
-
(* Convert permission decision to proto result *)
109
-
let proto_result =
110
-
Permissions.Decision.to_proto_result ~original_input:input decision
162
+
let response =
163
+
Control_response.success ~request_id ~response:(Some response_data)
111
164
in
112
-
113
-
(* Encode to JSON *)
165
+
Transport.send t.transport response
166
+
| Some server ->
167
+
let mcp_response = Mcp_server.handle_json_message server message in
168
+
Log.debug (fun m -> m "MCP response: %s" (json_to_string mcp_response));
114
169
let response_data =
115
-
match Jsont.Json.encode Proto.Permissions.Result.jsont proto_result with
116
-
| Ok json -> json
117
-
| Error err ->
118
-
Log.err (fun m -> m "Failed to encode permission result: %s" err);
119
-
failwith "Permission result encoding failed"
170
+
J.object' [ J.member (J.name "mcp_response") mcp_response ]
120
171
in
121
172
let response =
122
173
Control_response.success ~request_id ~response:(Some response_data)
123
174
in
124
-
Log.info (fun m ->
125
-
m "Sending control response: %s" (json_to_string response));
126
175
Transport.send t.transport response
127
-
| Sdk_control.Request.Hook_callback req -> (
128
-
let callback_id = req.callback_id in
129
-
let input = req.input in
130
-
let _tool_use_id = req.tool_use_id in
131
-
Log.info (fun m ->
132
-
m "Hook callback request for callback_id: %s" callback_id);
133
176
134
-
try
135
-
let callback = Hashtbl.find t.hook_callbacks callback_id in
136
-
let result = callback input in
177
+
let handle_control_request t (ctrl_req : Control.control_request) =
178
+
let request_id = ctrl_req.request_id in
179
+
Log.info (fun m -> m "Handling control request: %s" request_id);
137
180
138
-
let result_json =
139
-
Jsont.Json.encode Proto.Hooks.result_jsont result
140
-
|> Err.get_ok ~msg:"Failed to encode hook result: "
141
-
in
142
-
Log.debug (fun m ->
143
-
m "Hook result JSON: %s" (json_to_string result_json));
144
-
let response =
145
-
Control_response.success ~request_id ~response:(Some result_json)
146
-
in
147
-
Log.info (fun m -> m "Hook callback succeeded, sending response");
148
-
Transport.send t.transport response
149
-
with
150
-
| Not_found ->
151
-
let error_msg =
152
-
Printf.sprintf "Hook callback not found: %s" callback_id
153
-
in
154
-
Log.err (fun m -> m "%s" error_msg);
155
-
Transport.send t.transport
156
-
(Control_response.error ~request_id ~code:`Method_not_found
157
-
~message:error_msg ())
158
-
| exn ->
159
-
let error_msg =
160
-
Printf.sprintf "Hook callback error: %s" (Printexc.to_string exn)
161
-
in
162
-
Log.err (fun m -> m "%s" error_msg);
163
-
Transport.send t.transport
164
-
(Control_response.error ~request_id ~code:`Internal_error
165
-
~message:error_msg ()))
166
-
| Sdk_control.Request.Mcp_message req -> (
167
-
let module
168
-
(* Handle MCP request for in-process SDK servers *)
169
-
J =
170
-
Jsont.Json
171
-
in
172
-
let server_name = req.server_name in
173
-
let message = req.message in
174
-
Log.info (fun m -> m "MCP request for server '%s'" server_name);
175
-
176
-
match Hashtbl.find_opt t.mcp_servers server_name with
177
-
| None ->
178
-
let error_msg =
179
-
Printf.sprintf "MCP server '%s' not found" server_name
180
-
in
181
-
Log.err (fun m -> m "%s" error_msg);
182
-
(* Return JSONRPC error in mcp_response format *)
183
-
let mcp_error =
184
-
J.object'
185
-
[
186
-
J.mem (J.name "jsonrpc") (J.string "2.0");
187
-
J.mem (J.name "id") (J.null ());
188
-
J.mem (J.name "error")
189
-
(J.object'
190
-
[
191
-
J.mem (J.name "code") (J.number (-32601.0));
192
-
J.mem (J.name "message") (J.string error_msg);
193
-
]);
194
-
]
195
-
in
196
-
let response_data =
197
-
J.object' [ J.mem (J.name "mcp_response") mcp_error ]
198
-
in
199
-
let response =
200
-
Control_response.success ~request_id ~response:(Some response_data)
201
-
in
202
-
Transport.send t.transport response
203
-
| Some server ->
204
-
let mcp_response = Mcp_server.handle_json_message server message in
205
-
Log.debug (fun m ->
206
-
m "MCP response: %s" (json_to_string mcp_response));
207
-
let response_data =
208
-
J.object' [ J.mem (J.name "mcp_response") mcp_response ]
209
-
in
210
-
let response =
211
-
Control_response.success ~request_id ~response:(Some response_data)
212
-
in
213
-
Transport.send t.transport response)
181
+
match ctrl_req.request with
182
+
| Control.Request.Permission req ->
183
+
handle_permission_request t ~request_id req
184
+
| Control.Request.Hook_callback req -> handle_hook_callback t ~request_id req
185
+
| Control.Request.Mcp_message req -> handle_mcp_message t ~request_id req
214
186
| _ ->
215
187
(* Other request types not handled here *)
216
188
let error_msg = "Unsupported control request type" in
···
220
192
221
193
let handle_control_response t control_resp =
222
194
let request_id =
223
-
match control_resp.Sdk_control.response with
224
-
| Sdk_control.Response.Success s -> s.request_id
225
-
| Sdk_control.Response.Error e -> e.request_id
195
+
match control_resp.Control.response with
196
+
| Control.Response.Success s -> s.request_id
197
+
| Control.Response.Error e -> e.request_id
226
198
in
227
199
Log.debug (fun m ->
228
200
m "Received control response for request_id: %s" request_id);
229
201
230
202
(* Store the response as JSON and signal waiting threads *)
231
203
let json =
232
-
Jsont.Json.encode Sdk_control.control_response_jsont control_resp
233
-
|> Err.get_ok ~msg:"Failed to encode control response: "
204
+
encode_or_raise ~msg:"Failed to encode control response: "
205
+
Control.control_response_jsont control_resp
234
206
in
235
207
Eio.Mutex.use_rw ~protect:false t.control_mutex (fun () ->
236
208
Hashtbl.replace t.control_responses request_id json;
···
244
216
Log.debug (fun m -> m "Handle messages: EOF received");
245
217
Seq.Nil
246
218
| Some line -> (
247
-
(* Use unified Incoming codec for all message types *)
248
-
match Jsont_bytesrw.decode_string' Incoming.jsont line with
219
+
match Json.of_string Incoming.json line with
249
220
| Ok incoming -> Seq.Cons (incoming, loop)
250
221
| Error err ->
251
222
Log.err (fun m ->
252
223
m "Failed to decode incoming message: %s\nLine: %s"
253
-
(Jsont.Error.to_string err)
254
-
line);
224
+
(Json.Error.to_string err) line);
255
225
loop ())
256
226
in
257
227
Log.debug (fun m -> m "Starting message handler");
···
287
257
m "Received control request (request_id: %s)"
288
258
ctrl_req.request_id);
289
259
handle_control_request t ctrl_req;
260
+
loop rest
261
+
| Incoming.Rate_limit_event ->
262
+
Log.debug (fun m -> m "Received rate_limit_event (ignored)");
290
263
loop rest)
291
264
and emit_responses responses rest =
292
265
match responses with
···
295
268
in
296
269
loop raw_seq
297
270
298
-
let create ?(options = Options.default) ~sw ~process_mgr ~clock () =
271
+
let register_hooks t ~options ~hook_callbacks ~next_callback_id =
272
+
let register_matcher event_name (pattern, callback) =
273
+
let callback_id = Fmt.str "hook_%d" !next_callback_id in
274
+
incr next_callback_id;
275
+
Hashtbl.add hook_callbacks callback_id callback;
276
+
Log.debug (fun m ->
277
+
m "Registered callback: %s for event: %s" callback_id event_name);
278
+
Hook_matcher_wire.{ matcher = pattern; hook_callback_ids = [ callback_id ] }
279
+
in
280
+
Options.hooks options
281
+
|> Option.iter (fun hooks_config ->
282
+
Log.info (fun m -> m "Registering hooks...");
283
+
let callbacks_by_event = Hooks.callbacks hooks_config in
284
+
let hooks_list =
285
+
List.map
286
+
(fun (event, matchers) ->
287
+
let event_name = Hooks.event_to_string event in
288
+
let matcher_wires =
289
+
List.map (register_matcher event_name) matchers
290
+
in
291
+
(event_name, Hook_matcher_wire.encode matcher_wires))
292
+
callbacks_by_event
293
+
in
294
+
let request = Control.Request.initialize ~hooks:hooks_list () in
295
+
let ctrl_req = Control.request ~request_id:"init_hooks" ~request () in
296
+
let initialize_msg =
297
+
encode_or_raise ~msg:"Failed to encode initialize request: "
298
+
Control.json ctrl_req
299
+
in
300
+
Log.info (fun m -> m "Sending hooks initialize request");
301
+
Transport.send t.transport initialize_msg)
302
+
303
+
let v ?(options = Options.default) ~sw ~process_mgr ~clock () =
299
304
(* Automatically enable permission prompt tool when callback is configured
300
305
(matching Python SDK behavior in client.py:104-121) *)
301
306
let options =
···
305
310
Options.with_permission_prompt_tool_name "stdio" options
306
311
| _ -> options
307
312
in
308
-
let transport = Transport.create ~sw ~process_mgr ~options () in
313
+
let transport = Transport.v ~sw ~process_mgr ~options () in
309
314
310
315
(* Setup hook callbacks *)
311
316
let hook_callbacks = Hashtbl.create 16 in
···
335
340
}
336
341
in
337
342
338
-
(* Register hooks and send initialize if hooks are configured *)
339
-
Options.hooks options
340
-
|> Option.iter (fun hooks_config ->
341
-
Log.info (fun m -> m "Registering hooks...");
342
-
343
-
(* Get callbacks in wire format from the new Hooks API *)
344
-
let callbacks_by_event = Hooks.get_callbacks hooks_config in
345
-
346
-
(* Build hooks configuration with callback IDs as (string * Jsont.json) list *)
347
-
let hooks_list =
348
-
List.map
349
-
(fun (event, matchers) ->
350
-
let event_name = Proto.Hooks.event_to_string event in
351
-
let matcher_wires =
352
-
List.map
353
-
(fun (pattern, callback) ->
354
-
let callback_id =
355
-
Printf.sprintf "hook_%d" !next_callback_id
356
-
in
357
-
incr next_callback_id;
358
-
Hashtbl.add hook_callbacks callback_id callback;
359
-
Log.debug (fun m ->
360
-
m "Registered callback: %s for event: %s" callback_id
361
-
event_name);
362
-
Hook_matcher_wire.
363
-
{ matcher = pattern; hook_callback_ids = [ callback_id ] })
364
-
matchers
365
-
in
366
-
(event_name, Hook_matcher_wire.encode matcher_wires))
367
-
callbacks_by_event
368
-
in
369
-
370
-
(* Create initialize request using Sdk_control codec *)
371
-
let request = Sdk_control.Request.initialize ~hooks:hooks_list () in
372
-
let ctrl_req =
373
-
Sdk_control.create_request ~request_id:"init_hooks" ~request ()
374
-
in
375
-
let initialize_msg =
376
-
Jsont.Json.encode Sdk_control.jsont ctrl_req
377
-
|> Err.get_ok ~msg:"Failed to encode initialize request: "
378
-
in
379
-
Log.info (fun m -> m "Sending hooks initialize request");
380
-
Transport.send t.transport initialize_msg);
381
-
343
+
register_hooks t ~options ~hook_callbacks ~next_callback_id;
382
344
t
383
345
384
-
(* Helper to send a message with proper "type" wrapper via Proto.Outgoing *)
385
346
let send_message t msg =
386
-
Log.info (fun m -> m "→ %a" Message.pp msg);
387
-
let proto_msg = Message.to_proto msg in
388
-
let outgoing = Proto.Outgoing.Message proto_msg in
389
-
let json = Proto.Outgoing.to_json outgoing in
347
+
Log.info (fun m -> m "-> %a" Message.pp msg);
348
+
let outgoing = Outgoing.Message msg in
349
+
let json = Outgoing.to_json outgoing in
390
350
Transport.send t.transport json
391
351
392
352
let query t prompt =
···
480
440
let discovered_permissions t =
481
441
t.permission_log |> Option.map ( ! ) |> Option.value ~default:[]
482
442
443
+
let decode_or_raise ~msg codec v =
444
+
Json.decode codec v |> Result.map_error Json.Error.to_string |> Error.ok' ~msg
445
+
446
+
let decode_control_response response_json =
447
+
let response_field_codec =
448
+
let open Json.Codec in
449
+
Object.map ~kind:"ResponseField" Fun.id
450
+
|> Object.member "response" Value.t ~enc:Fun.id
451
+
|> Object.seal
452
+
in
453
+
let response_data =
454
+
decode_or_raise ~msg:"Failed to extract response field: "
455
+
response_field_codec response_json
456
+
in
457
+
let response =
458
+
decode_or_raise ~msg:"Failed to decode response: " Control.Response.json
459
+
response_data
460
+
in
461
+
match response with
462
+
| Control.Response.Success s -> s.response
463
+
| Control.Response.Error e ->
464
+
raise
465
+
(Failure
466
+
(Fmt.str "Control request failed: [%d] %s" e.error.code
467
+
e.error.message))
468
+
483
469
(* Helper to send a control request and wait for response *)
484
470
let send_control_request t ~request_id request =
485
-
(* Send the control request *)
486
-
let control_msg = Sdk_control.create_request ~request_id ~request () in
471
+
let control_msg = Control.request ~request_id ~request () in
487
472
let json =
488
-
Jsont.Json.encode Sdk_control.jsont control_msg
489
-
|> Err.get_ok ~msg:"Failed to encode control request: "
473
+
encode_or_raise ~msg:"Failed to encode control request: " Control.json
474
+
control_msg
490
475
in
491
476
Log.info (fun m -> m "Sending control request: %s" (json_to_string json));
492
477
Transport.send t.transport json;
···
508
493
if elapsed > max_wait then
509
494
raise
510
495
(Failure
511
-
(Printf.sprintf "Timeout waiting for control response: %s"
496
+
(Fmt.str "Timeout waiting for control response: %s"
512
497
request_id))
513
498
else (
514
499
(* Release mutex and wait for signal *)
···
519
504
let response_json = wait_for_response () in
520
505
Log.debug (fun m ->
521
506
m "Received control response: %s" (json_to_string response_json));
522
-
523
-
(* Parse the response - extract the "response" field using jsont codec *)
524
-
let response_field_codec =
525
-
Jsont.Object.map ~kind:"ResponseField" Fun.id
526
-
|> Jsont.Object.mem "response" Jsont.json ~enc:Fun.id
527
-
|> Jsont.Object.finish
528
-
in
529
-
let response_data =
530
-
Jsont.Json.decode response_field_codec response_json
531
-
|> Err.get_ok' ~msg:"Failed to extract response field: "
532
-
in
533
-
let response =
534
-
Jsont.Json.decode Sdk_control.Response.jsont response_data
535
-
|> Err.get_ok' ~msg:"Failed to decode response: "
536
-
in
537
-
match response with
538
-
| Sdk_control.Response.Success s -> s.response
539
-
| Sdk_control.Response.Error e ->
540
-
raise
541
-
(Failure
542
-
(Printf.sprintf "Control request failed: [%d] %s" e.error.code
543
-
e.error.message))
507
+
decode_control_response response_json
544
508
545
509
let set_permission_mode t mode =
546
-
let request_id = Printf.sprintf "set_perm_mode_%f" (Eio.Time.now t.clock) in
547
-
let proto_mode = Permissions.Mode.to_proto mode in
548
-
let request = Sdk_control.Request.set_permission_mode ~mode:proto_mode () in
510
+
let request_id = Fmt.str "set_perm_mode_%f" (Eio.Time.now t.clock) in
511
+
let request = Control.Request.set_permission_mode ~mode () in
549
512
let _response = send_control_request t ~request_id request in
550
513
Log.info (fun m ->
551
514
m "Permission mode set to: %s" (Permissions.Mode.to_string mode))
552
515
553
516
let set_model t model =
554
517
let model_str = Model.to_string model in
555
-
let request_id = Printf.sprintf "set_model_%f" (Eio.Time.now t.clock) in
556
-
let request = Sdk_control.Request.set_model ~model:model_str () in
518
+
let request_id = Fmt.str "set_model_%f" (Eio.Time.now t.clock) in
519
+
let request = Control.Request.set_model ~model:model_str () in
557
520
let _response = send_control_request t ~request_id request in
558
521
Log.info (fun m -> m "Model set to: %s" model_str)
559
522
560
-
let get_server_info t =
561
-
let request_id = Printf.sprintf "get_server_info_%f" (Eio.Time.now t.clock) in
562
-
let request = Sdk_control.Request.get_server_info () in
523
+
let server_info t =
524
+
let request_id = Fmt.str "get_server_info_%f" (Eio.Time.now t.clock) in
525
+
let request = Control.Request.get_server_info () in
563
526
let response_data =
564
527
send_control_request t ~request_id request
565
528
|> Option.to_result ~none:"No response data from get_server_info request"
566
-
|> Err.get_ok ~msg:""
529
+
|> Error.ok ~msg:""
567
530
in
568
531
let server_info =
569
-
Jsont.Json.decode Sdk_control.Server_info.jsont response_data
570
-
|> Err.get_ok' ~msg:"Failed to decode server info: "
532
+
decode_or_raise ~msg:"Failed to decode server info: "
533
+
Control.Server_info.json response_data
571
534
in
572
535
Log.info (fun m ->
573
536
m "Retrieved server info: %a"
574
-
(Jsont.pp_value Sdk_control.Server_info.jsont ())
537
+
(Json.pp_value Control.Server_info.json)
575
538
server_info);
576
-
Server_info.of_sdk_control server_info
539
+
Server_info.of_control server_info
577
540
578
541
module Advanced = struct
579
542
let send_message t msg = send_message t msg
···
584
547
585
548
let send_raw t control =
586
549
let json =
587
-
Jsont.Json.encode Sdk_control.jsont control
588
-
|> Err.get_ok ~msg:"Failed to encode control message: "
550
+
encode_or_raise ~msg:"Failed to encode control message: " Control.json
551
+
control
589
552
in
590
553
Log.info (fun m -> m "→ Raw control: %s" (json_to_string json));
591
554
Transport.send t.transport json
+53
-59
lib/client.mli
+53
-59
lib/client.mli
···
12
12
{2 Basic Usage}
13
13
14
14
{[
15
-
Eio.Switch.run @@ fun sw ->
16
-
let client = Client.create ~sw ~process_mgr ~clock () in
17
-
Client.query client "What is 2+2?";
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
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
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
26
]}
27
27
28
28
{2 Features}
···
35
35
36
36
{2 Message Flow}
37
37
38
-
1. Create a client with {!create} 2. Send messages with {!query} or
38
+
1. Create a client with {!v} 2. Send messages with {!query} or
39
39
{!Advanced.send_message} 3. Receive responses with {!receive} or
40
40
{!receive_all} 4. Continue multi-turn conversations by sending more messages
41
41
5. Client automatically cleans up when the switch exits
···
47
47
- Server capability introspection *)
48
48
49
49
val src : Logs.Src.t
50
-
(** The log source for client operations *)
50
+
(** The log source for client operations. *)
51
51
52
52
type t
53
53
(** The type of Claude clients. *)
···
57
57
The session ID is provided in system init messages and uniquely identifies
58
58
the current conversation session. *)
59
59
60
-
val create :
60
+
val v :
61
61
?options:Options.t ->
62
62
sw:Eio.Switch.t ->
63
63
process_mgr:_ Eio.Process.mgr ->
64
64
clock:float Eio.Time.clock_ty Eio.Resource.t ->
65
65
unit ->
66
66
t
67
-
(** [create ?options ~sw ~process_mgr ~clock ()] creates a new Claude client.
67
+
(** [v ?options ~sw ~process_mgr ~clock ()] creates a new Claude client.
68
68
69
69
@param options Configuration options (defaults to {!Options.default})
70
70
@param sw Eio switch for resource management
71
71
@param process_mgr Eio process manager for spawning the Claude CLI
72
-
@param clock Eio clock for time operations *)
72
+
@param clock Eio clock for time operations. *)
73
73
74
74
(** {1 Simple Query Interface} *)
75
75
···
81
81
{!Advanced.send_message} instead. *)
82
82
83
83
val respond_to_tool :
84
-
t ->
85
-
tool_use_id:string ->
86
-
content:Jsont.json ->
87
-
?is_error:bool ->
88
-
unit ->
89
-
unit
84
+
t -> tool_use_id:string -> content:Json.t -> ?is_error:bool -> unit -> unit
90
85
(** [respond_to_tool t ~tool_use_id ~content ?is_error ()] responds to a tool
91
86
use request.
92
87
···
97
92
@param tool_use_id The ID from the {!Response.Tool_use.t} event
98
93
@param content
99
94
The result content (can be a string or array of content blocks)
100
-
@param is_error Whether this is an error response (default: false) *)
95
+
@param is_error Whether this is an error response (default: false). *)
101
96
102
-
val respond_to_tools : t -> (string * Jsont.json * bool option) list -> unit
97
+
val respond_to_tools : t -> (string * Json.t * bool option) list -> unit
103
98
(** [respond_to_tools t responses] responds to multiple tool use requests at
104
99
once.
105
100
···
111
106
112
107
Example:
113
108
{[
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
-
]
109
+
Client.respond_to_tools client
110
+
[
111
+
("tool_use_123", Json.Value.string "Success", None);
112
+
("tool_use_456", Json.Value.string "Error occurred", Some true);
113
+
]
119
114
]} *)
120
115
121
116
val clear_tool_response_tracking : t -> unit
···
136
131
137
132
Example:
138
133
{[
139
-
let my_handler =
140
-
object
141
-
inherit Claude.Handler.default
142
-
method! on_text t = print_endline (Response.Text.content t)
134
+
let my_handler =
135
+
object
136
+
inherit Claude.Handler.default
137
+
method! on_text t = print_endline (Response.Text.content t)
143
138
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
139
+
method! on_complete c =
140
+
Printf.printf "Cost: $%.4f\n"
141
+
(Option.value ~default:0.0 (Response.Complete.total_cost_usd c))
142
+
end
143
+
in
144
+
Client.query client "Hello";
145
+
Client.run client ~handler:my_handler
151
146
]} *)
152
147
153
148
val receive : t -> Response.t Seq.t
···
192
187
193
188
{[
194
189
(* Start with strict permissions *)
195
-
let client = Client.create ~sw ~process_mgr ~clock
190
+
let client = Client.v ~sw ~process_mgr ~clock
196
191
~options:(Options.default
197
192
|> Options.with_permission_mode Permissions.Mode.Default) ()
198
193
in
···
211
206
212
207
{[
213
208
(* Use powerful model for complex analysis *)
214
-
let client = Client.create ~sw ~process_mgr ~clock
209
+
let client = Client.v ~sw ~process_mgr ~clock
215
210
~options:(Options.default |> Options.with_model "claude-sonnet-4-5") ()
216
211
in
217
212
···
228
223
{2 Example: Server Introspection}
229
224
230
225
{[
231
-
let info = Client.get_server_info client in
232
-
Printf.printf "Claude CLI version: %s\n"
233
-
(Sdk_control.Server_info.version info);
234
-
Printf.printf "Capabilities: %s\n"
235
-
(String.concat ", " (Sdk_control.Server_info.capabilities info))
226
+
let info = Client.server_info client in
227
+
Printf.printf "Claude CLI version: %s\n" (Control.Server_info.version info);
228
+
Printf.printf "Capabilities: %s\n"
229
+
(String.concat ", " (Control.Server_info.capabilities info))
236
230
]} *)
237
231
238
232
val set_permission_mode : t -> Permissions.Mode.t -> unit
···
243
237
- {!Permissions.Mode.Default} - Prompt for all permissions
244
238
- {!Permissions.Mode.Accept_edits} - Auto-accept file edits
245
239
- {!Permissions.Mode.Plan} - Planning mode with restricted execution
246
-
- {!Permissions.Mode.Bypass_permissions} - Skip all permission checks
240
+
- {!Permissions.Mode.Bypass_permissions} - Skip all permission checks.
247
241
248
-
@raise Failure if the server returns an error *)
242
+
@raise Failure if the server returns an error. *)
249
243
250
244
val set_model : t -> Model.t -> unit
251
245
(** [set_model t model] switches to a different AI model mid-conversation.
···
255
249
- [`Opus_4] - Maximum capability for complex tasks
256
250
- [`Haiku_4] - Fast and cost-effective
257
251
258
-
@raise Failure if the model is invalid or unavailable *)
252
+
@raise Failure if the model is invalid or unavailable. *)
259
253
260
-
val get_server_info : t -> Server_info.t
261
-
(** [get_server_info t] retrieves server capabilities and metadata.
254
+
val server_info : t -> Server_info.t
255
+
(** [server_info t] retrieves server capabilities and metadata.
262
256
263
257
Returns information about:
264
258
- Server version string
···
268
262
269
263
Useful for feature detection and debugging.
270
264
271
-
@raise Failure if the server returns an error *)
265
+
@raise Failure if the server returns an error. *)
272
266
273
267
(** {1 Permission Discovery} *)
274
268
···
299
293
val send_user_message : t -> Message.User.t -> unit
300
294
(** [send_user_message t msg] sends a user message to Claude. *)
301
295
302
-
val send_raw : t -> Sdk_control.t -> unit
296
+
val send_raw : t -> Control.t -> unit
303
297
(** [send_raw t control] sends a raw SDK control message.
304
298
305
299
This is for advanced use cases that need direct control protocol access.
306
300
*)
307
301
308
-
val send_json : t -> Jsont.json -> unit
302
+
val send_json : t -> Json.t -> unit
309
303
(** [send_json t json] sends raw JSON to Claude.
310
304
311
305
This is the lowest-level send operation. Use with caution. *)
···
314
308
(** [receive_raw t] returns a lazy sequence of raw incoming messages.
315
309
316
310
This includes all message types before Response conversion:
317
-
- {!Proto.Incoming.t.constructor-Message} - Regular messages
318
-
- {!Proto.Incoming.t.constructor-Control_response} - Control responses
319
-
(normally handled internally)
320
-
- {!Proto.Incoming.t.constructor-Control_request} - Control requests
321
-
(normally handled internally)
311
+
- {!Incoming.t.constructor-Message} - Regular messages
312
+
- {!Incoming.t.constructor-Control_response} - Control responses (normally
313
+
handled internally)
314
+
- {!Incoming.t.constructor-Control_request} - Control requests (normally
315
+
handled internally)
322
316
323
317
Most users should use {!receive} or {!run} instead. *)
324
318
end
+104
-76
lib/content_block.ml
+104
-76
lib/content_block.ml
···
8
8
module Log = (val Logs.src_log src : Logs.LOG)
9
9
10
10
module Text = struct
11
-
type t = Proto.Content_block.Text.t
11
+
type t = { text : string; unknown : Unknown.t }
12
12
13
-
let text = Proto.Content_block.Text.text
14
-
let of_proto proto = proto
15
-
let to_proto t = t
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 json : t Json.codec =
19
+
let open Json.Codec in
20
+
Object.map ~kind:"Text" make
21
+
|> Object.member "text" string ~enc:text
22
+
|> Object.keep_unknown Unknown.mems ~enc:unknown
23
+
|> Object.seal
16
24
end
17
25
18
26
module Tool_use = struct
19
-
type t = Proto.Content_block.Tool_use.t
27
+
type t = { id : string; name : string; input : Json.t; unknown : Unknown.t }
28
+
29
+
let create ~id ~name ~input = { id; name; input; unknown = Unknown.empty }
30
+
let make id name input unknown = { id; name; input; unknown }
31
+
let id t = t.id
32
+
let name t = t.name
33
+
let input t = Tool_input.of_json t.input
34
+
let unknown t = t.unknown
20
35
21
-
let id = Proto.Content_block.Tool_use.id
22
-
let name = Proto.Content_block.Tool_use.name
23
-
let input t = Proto.Content_block.Tool_use.input t |> Tool_input.of_json
24
-
let of_proto proto = proto
25
-
let to_proto t = t
36
+
let json : t Json.codec =
37
+
let open Json.Codec in
38
+
Object.map ~kind:"Tool_use" make
39
+
|> Object.member "id" string ~enc:id
40
+
|> Object.member "name" string ~enc:name
41
+
|> Object.member "input" Value.t ~enc:(fun t -> t.input)
42
+
|> Object.keep_unknown Unknown.mems ~enc:unknown
43
+
|> Object.seal
26
44
end
27
45
28
46
module Tool_result = struct
29
-
type t = Proto.Content_block.Tool_result.t
47
+
type t = {
48
+
tool_use_id : string;
49
+
content : Json.t option;
50
+
is_error : bool option;
51
+
unknown : Unknown.t;
52
+
}
30
53
31
-
let tool_use_id = Proto.Content_block.Tool_result.tool_use_id
32
-
let content = Proto.Content_block.Tool_result.content
33
-
let is_error = Proto.Content_block.Tool_result.is_error
34
-
let of_proto proto = proto
35
-
let to_proto t = t
54
+
let create ~tool_use_id ?content ?is_error () =
55
+
{ tool_use_id; content; is_error; unknown = Unknown.empty }
56
+
57
+
let make tool_use_id content is_error unknown =
58
+
{ tool_use_id; content; is_error; unknown }
59
+
60
+
let tool_use_id t = t.tool_use_id
61
+
let content t = t.content
62
+
let is_error t = t.is_error
63
+
let unknown t = t.unknown
64
+
65
+
let json : t Json.codec =
66
+
let open Json.Codec in
67
+
Object.map ~kind:"Tool_result" make
68
+
|> Object.member "tool_use_id" string ~enc:tool_use_id
69
+
|> Object.opt_member "content" Value.t ~enc:content
70
+
|> Object.opt_member "is_error" bool ~enc:is_error
71
+
|> Object.keep_unknown Unknown.mems ~enc:unknown
72
+
|> Object.seal
36
73
end
37
74
38
75
module Thinking = struct
39
-
type t = Proto.Content_block.Thinking.t
76
+
type t = { thinking : string; signature : string; unknown : Unknown.t }
77
+
78
+
let create ~thinking ~signature =
79
+
{ thinking; signature; unknown = Unknown.empty }
40
80
41
-
let thinking = Proto.Content_block.Thinking.thinking
42
-
let signature = Proto.Content_block.Thinking.signature
43
-
let of_proto proto = proto
44
-
let to_proto t = t
81
+
let make thinking signature unknown = { thinking; signature; unknown }
82
+
let thinking t = t.thinking
83
+
let signature t = t.signature
84
+
let unknown t = t.unknown
85
+
86
+
let json : t Json.codec =
87
+
let open Json.Codec in
88
+
Object.map ~kind:"Thinking" make
89
+
|> Object.member "thinking" string ~enc:thinking
90
+
|> Object.member "signature" string ~enc:signature
91
+
|> Object.keep_unknown Unknown.mems ~enc:unknown
92
+
|> Object.seal
45
93
end
46
94
47
95
type t =
···
50
98
| Tool_result of Tool_result.t
51
99
| Thinking of Thinking.t
52
100
53
-
let text s =
54
-
let proto = Proto.Content_block.text s in
55
-
match proto with
56
-
| Proto.Content_block.Text proto_text -> Text (Text.of_proto proto_text)
57
-
| _ -> failwith "Internal error: Proto.Content_block.text returned non-Text"
101
+
let text s = Text (Text.create s)
58
102
59
103
let tool_use ~id ~name ~input =
60
-
let json_input = Tool_input.to_json input in
61
-
let proto = Proto.Content_block.tool_use ~id ~name ~input:json_input in
62
-
match proto with
63
-
| Proto.Content_block.Tool_use proto_tool_use ->
64
-
Tool_use (Tool_use.of_proto proto_tool_use)
65
-
| _ ->
66
-
failwith
67
-
"Internal error: Proto.Content_block.tool_use returned non-Tool_use"
104
+
Tool_use (Tool_use.create ~id ~name ~input:(Tool_input.to_json input))
68
105
69
106
let tool_result ~tool_use_id ?content ?is_error () =
70
-
let proto =
71
-
Proto.Content_block.tool_result ~tool_use_id ?content ?is_error ()
72
-
in
73
-
match proto with
74
-
| Proto.Content_block.Tool_result proto_tool_result ->
75
-
Tool_result (Tool_result.of_proto proto_tool_result)
76
-
| _ ->
77
-
failwith
78
-
"Internal error: Proto.Content_block.tool_result returned \
79
-
non-Tool_result"
107
+
Tool_result (Tool_result.create ~tool_use_id ?content ?is_error ())
80
108
81
109
let thinking ~thinking ~signature =
82
-
let proto = Proto.Content_block.thinking ~thinking ~signature in
83
-
match proto with
84
-
| Proto.Content_block.Thinking proto_thinking ->
85
-
Thinking (Thinking.of_proto proto_thinking)
86
-
| _ ->
87
-
failwith
88
-
"Internal error: Proto.Content_block.thinking returned non-Thinking"
89
-
90
-
let of_proto proto =
91
-
match proto with
92
-
| Proto.Content_block.Text t -> Text (Text.of_proto t)
93
-
| Proto.Content_block.Tool_use t -> Tool_use (Tool_use.of_proto t)
94
-
| Proto.Content_block.Tool_result t -> Tool_result (Tool_result.of_proto t)
95
-
| Proto.Content_block.Thinking t -> Thinking (Thinking.of_proto t)
96
-
97
-
let to_proto = function
98
-
| Text t -> Proto.Content_block.Text (Text.to_proto t)
99
-
| Tool_use t -> Proto.Content_block.Tool_use (Tool_use.to_proto t)
100
-
| Tool_result t -> Proto.Content_block.Tool_result (Tool_result.to_proto t)
101
-
| Thinking t -> Proto.Content_block.Thinking (Thinking.to_proto t)
110
+
Thinking (Thinking.create ~thinking ~signature)
102
111
103
-
let log_received t =
104
-
let proto = to_proto t in
105
-
Log.debug (fun m ->
106
-
m "Received content block: %a"
107
-
(Jsont.pp_value Proto.Content_block.jsont ())
108
-
proto)
112
+
let json : t Json.codec =
113
+
let open Json.Codec in
114
+
let case_map kind obj dec = Object.Case.map kind obj ~dec in
115
+
let case_text = case_map "text" Text.json (fun v -> Text v) in
116
+
let case_tool_use = case_map "tool_use" Tool_use.json (fun v -> Tool_use v) in
117
+
let case_tool_result =
118
+
case_map "tool_result" Tool_result.json (fun v -> Tool_result v)
119
+
in
120
+
let case_thinking = case_map "thinking" Thinking.json (fun v -> Thinking v) in
121
+
let enc_case = function
122
+
| Text v -> Object.Case.value case_text v
123
+
| Tool_use v -> Object.Case.value case_tool_use v
124
+
| Tool_result v -> Object.Case.value case_tool_result v
125
+
| Thinking v -> Object.Case.value case_thinking v
126
+
in
127
+
let cases =
128
+
Object.Case.
129
+
[
130
+
make case_text;
131
+
make case_tool_use;
132
+
make case_tool_result;
133
+
make case_thinking;
134
+
]
135
+
in
136
+
Object.map ~kind:"Content_block" Fun.id
137
+
|> Object.case_member "type" string ~enc:Fun.id ~enc_case cases
138
+
~tag_to_string:Fun.id ~tag_compare:String.compare
139
+
|> Object.seal
109
140
110
-
let log_sending t =
111
-
let proto = to_proto t in
112
-
Log.debug (fun m ->
113
-
m "Sending content block: %a"
114
-
(Jsont.pp_value Proto.Content_block.jsont ())
115
-
proto)
141
+
let pp ppf t = Json.pp_value json ppf t
142
+
let log_received t = Log.debug (fun m -> m "Received content block: %a" pp t)
143
+
let log_sending t = Log.debug (fun m -> m "Sending content block: %a" pp t)
+21
-81
lib/content_block.mli
+21
-81
lib/content_block.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Content blocks in messages. Opaque types without wire concerns.
7
-
8
-
This module provides opaque wrapper types around the proto content block
9
-
types, hiding unknown fields and wire format details from the public API. *)
6
+
(** Content blocks in messages. *)
10
7
11
8
val src : Logs.Src.t
12
9
(** Log source for content block operations. *)
···
14
11
(** {1 Text Blocks} *)
15
12
16
13
module Text : sig
17
-
(** Plain text content blocks. *)
18
-
19
14
type t
20
-
(** The type of text blocks (opaque). *)
21
15
16
+
val create : string -> t
22
17
val text : t -> string
23
-
(** [text t] returns the text content of the block. *)
24
-
25
-
(** {1 Internal - for lib use only} *)
26
-
27
-
val of_proto : Proto.Content_block.Text.t -> t
28
-
(** [of_proto proto] wraps a proto text block. *)
29
-
30
-
val to_proto : t -> Proto.Content_block.Text.t
31
-
(** [to_proto t] extracts the proto text block. *)
18
+
val unknown : t -> Unknown.t
19
+
val json : t Json.codec
32
20
end
33
21
34
22
(** {1 Tool Use Blocks} *)
35
23
36
24
module Tool_use : sig
37
-
(** Tool invocation requests from the assistant. *)
38
-
39
25
type t
40
-
(** The type of tool use blocks (opaque). *)
41
26
27
+
val create : id:string -> name:string -> input:Json.t -> t
42
28
val id : t -> string
43
-
(** [id t] returns the unique identifier of the tool use. *)
44
-
45
29
val name : t -> string
46
-
(** [name t] returns the name of the tool being invoked. *)
47
30
48
31
val input : t -> Tool_input.t
49
-
(** [input t] returns the input parameters for the tool. *)
32
+
(** [input t] returns the tool input as a typed {!Tool_input.t}. *)
50
33
51
-
(** {1 Internal - for lib use only} *)
52
-
53
-
val of_proto : Proto.Content_block.Tool_use.t -> t
54
-
(** [of_proto proto] wraps a proto tool use block. *)
55
-
56
-
val to_proto : t -> Proto.Content_block.Tool_use.t
57
-
(** [to_proto t] extracts the proto tool use block. *)
34
+
val unknown : t -> Unknown.t
35
+
val json : t Json.codec
58
36
end
59
37
60
38
(** {1 Tool Result Blocks} *)
61
39
62
40
module Tool_result : sig
63
-
(** Results from tool invocations. *)
41
+
type t
64
42
65
-
type t
66
-
(** The type of tool result blocks (opaque). *)
43
+
val create :
44
+
tool_use_id:string -> ?content:Json.t -> ?is_error:bool -> unit -> t
67
45
68
46
val tool_use_id : t -> string
69
-
(** [tool_use_id t] returns the ID of the corresponding tool use. *)
70
-
71
-
val content : t -> Jsont.json option
72
-
(** [content t] returns the optional result content as raw JSON. *)
73
-
47
+
val content : t -> Json.t option
74
48
val is_error : t -> bool option
75
-
(** [is_error t] returns whether this result represents an error. *)
76
-
77
-
(** {1 Internal - for lib use only} *)
78
-
79
-
val of_proto : Proto.Content_block.Tool_result.t -> t
80
-
(** [of_proto proto] wraps a proto tool result block. *)
81
-
82
-
val to_proto : t -> Proto.Content_block.Tool_result.t
83
-
(** [to_proto t] extracts the proto tool result block. *)
49
+
val unknown : t -> Unknown.t
50
+
val json : t Json.codec
84
51
end
85
52
86
53
(** {1 Thinking Blocks} *)
87
54
88
55
module Thinking : sig
89
-
(** Assistant's internal reasoning blocks. *)
90
-
91
56
type t
92
-
(** The type of thinking blocks (opaque). *)
93
57
58
+
val create : thinking:string -> signature:string -> t
94
59
val thinking : t -> string
95
-
(** [thinking t] returns the thinking content. *)
96
-
97
60
val signature : t -> string
98
-
(** [signature t] returns the cryptographic signature. *)
99
-
100
-
(** {1 Internal - for lib use only} *)
101
-
102
-
val of_proto : Proto.Content_block.Thinking.t -> t
103
-
(** [of_proto proto] wraps a proto thinking block. *)
104
-
105
-
val to_proto : t -> Proto.Content_block.Thinking.t
106
-
(** [to_proto t] extracts the proto thinking block. *)
61
+
val unknown : t -> Unknown.t
62
+
val json : t Json.codec
107
63
end
108
64
109
65
(** {1 Content Block Union Type} *)
···
113
69
| Tool_use of Tool_use.t
114
70
| Tool_result of Tool_result.t
115
71
| Thinking of Thinking.t
116
-
(** The type of content blocks, which can be text, tool use, tool result,
117
-
or thinking. *)
72
+
73
+
val pp : Format.formatter -> t -> unit
118
74
119
75
(** {1 Constructors} *)
120
76
121
77
val text : string -> t
122
-
(** [text s] creates a text content block. *)
123
-
124
78
val tool_use : id:string -> name:string -> input:Tool_input.t -> t
125
-
(** [tool_use ~id ~name ~input] creates a tool use content block. *)
126
79
127
80
val tool_result :
128
-
tool_use_id:string -> ?content:Jsont.json -> ?is_error:bool -> unit -> t
129
-
(** [tool_result ~tool_use_id ?content ?is_error ()] creates a tool result
130
-
content block. Content can be a string or array. *)
81
+
tool_use_id:string -> ?content:Json.t -> ?is_error:bool -> unit -> t
131
82
132
83
val thinking : thinking:string -> signature:string -> t
133
-
(** [thinking ~thinking ~signature] creates a thinking content block. *)
134
-
135
-
(** {1 Conversion} *)
136
-
137
-
val of_proto : Proto.Content_block.t -> t
138
-
(** [of_proto proto] converts a proto content block to a lib content block. *)
139
-
140
-
val to_proto : t -> Proto.Content_block.t
141
-
(** [to_proto t] converts a lib content block to a proto content block. *)
84
+
val json : t Json.codec
142
85
143
86
(** {1 Logging} *)
144
87
145
88
val log_received : t -> unit
146
-
(** [log_received t] logs that a content block was received. *)
147
-
148
89
val log_sending : t -> unit
149
-
(** [log_sending t] logs that a content block is being sent. *)
+481
-33
lib/control.ml
+481
-33
lib/control.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
let src = Logs.Src.create "claude.control" ~doc:"Claude control messages"
6
+
open Json.Codec
7
+
8
+
let src = Logs.Src.create "claude.control" ~doc:"Claude control protocol"
7
9
8
10
module Log = (val Logs.src_log src : Logs.LOG)
9
11
10
-
type t = {
12
+
module Request = struct
13
+
type interrupt = { subtype : [ `Interrupt ]; unknown : Unknown.t }
14
+
15
+
type permission = {
16
+
subtype : [ `Can_use_tool ];
17
+
tool_name : string;
18
+
input : Json.t;
19
+
permission_suggestions : Permissions.Update.t list option;
20
+
blocked_path : string option;
21
+
unknown : Unknown.t;
22
+
}
23
+
24
+
type initialize = {
25
+
subtype : [ `Initialize ];
26
+
hooks : (string * Json.t) list option;
27
+
unknown : Unknown.t;
28
+
}
29
+
30
+
type set_permission_mode = {
31
+
subtype : [ `Set_permission_mode ];
32
+
mode : Permissions.Mode.t;
33
+
unknown : Unknown.t;
34
+
}
35
+
36
+
type hook_callback = {
37
+
subtype : [ `Hook_callback ];
38
+
callback_id : string;
39
+
input : Json.t;
40
+
tool_use_id : string option;
41
+
unknown : Unknown.t;
42
+
}
43
+
44
+
type mcp_message = {
45
+
subtype : [ `Mcp_message ];
46
+
server_name : string;
47
+
message : Json.t;
48
+
unknown : Unknown.t;
49
+
}
50
+
51
+
type set_model = {
52
+
subtype : [ `Set_model ];
53
+
model : string;
54
+
unknown : Unknown.t;
55
+
}
56
+
57
+
type get_server_info = { subtype : [ `Get_server_info ]; unknown : Unknown.t }
58
+
59
+
type t =
60
+
| Interrupt of interrupt
61
+
| Permission of permission
62
+
| Initialize of initialize
63
+
| Set_permission_mode of set_permission_mode
64
+
| Hook_callback of hook_callback
65
+
| Mcp_message of mcp_message
66
+
| Set_model of set_model
67
+
| Get_server_info of get_server_info
68
+
69
+
let interrupt ?(unknown = Unknown.empty) () =
70
+
Interrupt { subtype = `Interrupt; unknown }
71
+
72
+
let permission ~tool_name ~input ?permission_suggestions ?blocked_path
73
+
?(unknown = Unknown.empty) () =
74
+
Permission
75
+
{
76
+
subtype = `Can_use_tool;
77
+
tool_name;
78
+
input;
79
+
permission_suggestions;
80
+
blocked_path;
81
+
unknown;
82
+
}
83
+
84
+
let initialize ?hooks ?(unknown = Unknown.empty) () =
85
+
Initialize { subtype = `Initialize; hooks; unknown }
86
+
87
+
let set_permission_mode ~mode ?(unknown = Unknown.empty) () =
88
+
Set_permission_mode { subtype = `Set_permission_mode; mode; unknown }
89
+
90
+
let hook_callback ~callback_id ~input ?tool_use_id ?(unknown = Unknown.empty)
91
+
() =
92
+
Hook_callback
93
+
{ subtype = `Hook_callback; callback_id; input; tool_use_id; unknown }
94
+
95
+
let mcp_message ~server_name ~message ?(unknown = Unknown.empty) () =
96
+
Mcp_message { subtype = `Mcp_message; server_name; message; unknown }
97
+
98
+
let set_model ~model ?(unknown = Unknown.empty) () =
99
+
Set_model { subtype = `Set_model; model; unknown }
100
+
101
+
let get_server_info ?(unknown = Unknown.empty) () =
102
+
Get_server_info { subtype = `Get_server_info; unknown }
103
+
104
+
(* Individual record codecs *)
105
+
let interrupt_jsont : interrupt Json.codec =
106
+
let make (unknown : Unknown.t) : interrupt =
107
+
{ subtype = `Interrupt; unknown }
108
+
in
109
+
Object.map ~kind:"Interrupt" make
110
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : interrupt) -> r.unknown)
111
+
|> Object.seal
112
+
113
+
let permission_jsont : permission Json.codec =
114
+
let make tool_name input permission_suggestions blocked_path
115
+
(unknown : Unknown.t) : permission =
116
+
{
117
+
subtype = `Can_use_tool;
118
+
tool_name;
119
+
input;
120
+
permission_suggestions;
121
+
blocked_path;
122
+
unknown;
123
+
}
124
+
in
125
+
Object.map ~kind:"Permission" make
126
+
|> Object.member "tool_name" string ~enc:(fun (r : permission) ->
127
+
r.tool_name)
128
+
|> Object.member "input" Value.t ~enc:(fun (r : permission) -> r.input)
129
+
|> Object.opt_member "permission_suggestions" (list Permissions.Update.json)
130
+
~enc:(fun (r : permission) -> r.permission_suggestions)
131
+
|> Object.opt_member "blocked_path" string ~enc:(fun (r : permission) ->
132
+
r.blocked_path)
133
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : permission) -> r.unknown)
134
+
|> Object.seal
135
+
136
+
let initialize_jsont : initialize Json.codec =
137
+
(* The hooks field is an object with string keys and json values *)
138
+
let hooks_map_jsont = Object.as_string_map Value.t in
139
+
let module StringMap = Map.Make (String) in
140
+
let hooks_jsont =
141
+
map
142
+
~dec:(fun m -> StringMap.bindings m)
143
+
~enc:(fun l -> StringMap.of_seq (List.to_seq l))
144
+
hooks_map_jsont
145
+
in
146
+
let make hooks (unknown : Unknown.t) : initialize =
147
+
{ subtype = `Initialize; hooks; unknown }
148
+
in
149
+
Object.map ~kind:"Initialize" make
150
+
|> Object.opt_member "hooks" hooks_jsont ~enc:(fun (r : initialize) ->
151
+
r.hooks)
152
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : initialize) -> r.unknown)
153
+
|> Object.seal
154
+
155
+
let set_permission_mode_jsont : set_permission_mode Json.codec =
156
+
let make mode (unknown : Unknown.t) : set_permission_mode =
157
+
{ subtype = `Set_permission_mode; mode; unknown }
158
+
in
159
+
Object.map ~kind:"SetPermissionMode" make
160
+
|> Object.member "mode" Permissions.Mode.json
161
+
~enc:(fun (r : set_permission_mode) -> r.mode)
162
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : set_permission_mode) ->
163
+
r.unknown)
164
+
|> Object.seal
165
+
166
+
let hook_callback_jsont : hook_callback Json.codec =
167
+
let make callback_id input tool_use_id (unknown : Unknown.t) : hook_callback
168
+
=
169
+
{ subtype = `Hook_callback; callback_id; input; tool_use_id; unknown }
170
+
in
171
+
Object.map ~kind:"HookCallback" make
172
+
|> Object.member "callback_id" string ~enc:(fun (r : hook_callback) ->
173
+
r.callback_id)
174
+
|> Object.member "input" Value.t ~enc:(fun (r : hook_callback) -> r.input)
175
+
|> Object.opt_member "tool_use_id" string ~enc:(fun (r : hook_callback) ->
176
+
r.tool_use_id)
177
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : hook_callback) ->
178
+
r.unknown)
179
+
|> Object.seal
180
+
181
+
let mcp_message_jsont : mcp_message Json.codec =
182
+
let make server_name message (unknown : Unknown.t) : mcp_message =
183
+
{ subtype = `Mcp_message; server_name; message; unknown }
184
+
in
185
+
Object.map ~kind:"McpMessage" make
186
+
|> Object.member "server_name" string ~enc:(fun (r : mcp_message) ->
187
+
r.server_name)
188
+
|> Object.member "message" Value.t ~enc:(fun (r : mcp_message) -> r.message)
189
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : mcp_message) ->
190
+
r.unknown)
191
+
|> Object.seal
192
+
193
+
let set_model_jsont : set_model Json.codec =
194
+
let make model (unknown : Unknown.t) : set_model =
195
+
{ subtype = `Set_model; model; unknown }
196
+
in
197
+
Object.map ~kind:"SetModel" make
198
+
|> Object.member "model" string ~enc:(fun (r : set_model) -> r.model)
199
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : set_model) -> r.unknown)
200
+
|> Object.seal
201
+
202
+
let get_server_info_jsont : get_server_info Json.codec =
203
+
let make (unknown : Unknown.t) : get_server_info =
204
+
{ subtype = `Get_server_info; unknown }
205
+
in
206
+
Object.map ~kind:"GetServerInfo" make
207
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : get_server_info) ->
208
+
r.unknown)
209
+
|> Object.seal
210
+
211
+
(* Main variant codec using subtype discriminator *)
212
+
let json : t Json.codec =
213
+
let case_interrupt =
214
+
Object.Case.map "interrupt" interrupt_jsont ~dec:(fun v -> Interrupt v)
215
+
in
216
+
let case_permission =
217
+
Object.Case.map "can_use_tool" permission_jsont ~dec:(fun v ->
218
+
Permission v)
219
+
in
220
+
let case_initialize =
221
+
Object.Case.map "initialize" initialize_jsont ~dec:(fun v -> Initialize v)
222
+
in
223
+
let case_set_permission_mode =
224
+
Object.Case.map "set_permission_mode" set_permission_mode_jsont
225
+
~dec:(fun v -> Set_permission_mode v)
226
+
in
227
+
let case_hook_callback =
228
+
Object.Case.map "hook_callback" hook_callback_jsont ~dec:(fun v ->
229
+
Hook_callback v)
230
+
in
231
+
let case_mcp_message =
232
+
Object.Case.map "mcp_message" mcp_message_jsont ~dec:(fun v ->
233
+
Mcp_message v)
234
+
in
235
+
let case_set_model =
236
+
Object.Case.map "set_model" set_model_jsont ~dec:(fun v -> Set_model v)
237
+
in
238
+
let case_get_server_info =
239
+
Object.Case.map "get_server_info" get_server_info_jsont ~dec:(fun v ->
240
+
Get_server_info v)
241
+
in
242
+
243
+
let enc_case = function
244
+
| Interrupt v -> Object.Case.value case_interrupt v
245
+
| Permission v -> Object.Case.value case_permission v
246
+
| Initialize v -> Object.Case.value case_initialize v
247
+
| Set_permission_mode v -> Object.Case.value case_set_permission_mode v
248
+
| Hook_callback v -> Object.Case.value case_hook_callback v
249
+
| Mcp_message v -> Object.Case.value case_mcp_message v
250
+
| Set_model v -> Object.Case.value case_set_model v
251
+
| Get_server_info v -> Object.Case.value case_get_server_info v
252
+
in
253
+
254
+
let cases =
255
+
Object.Case.
256
+
[
257
+
make case_interrupt;
258
+
make case_permission;
259
+
make case_initialize;
260
+
make case_set_permission_mode;
261
+
make case_hook_callback;
262
+
make case_mcp_message;
263
+
make case_set_model;
264
+
make case_get_server_info;
265
+
]
266
+
in
267
+
268
+
Object.map ~kind:"Request" Fun.id
269
+
|> Object.case_member "subtype" string ~enc:Fun.id ~enc_case cases
270
+
~tag_to_string:Fun.id ~tag_compare:String.compare
271
+
|> Object.seal
272
+
end
273
+
274
+
module Response = struct
275
+
module Error_code = struct
276
+
type t =
277
+
[ `Parse_error
278
+
| `Invalid_request
279
+
| `Method_not_found
280
+
| `Invalid_params
281
+
| `Internal_error
282
+
| `Custom of int ]
283
+
284
+
let to_int : [< t ] -> int = function
285
+
| `Parse_error -> -32700
286
+
| `Invalid_request -> -32600
287
+
| `Method_not_found -> -32601
288
+
| `Invalid_params -> -32602
289
+
| `Internal_error -> -32603
290
+
| `Custom n -> n
291
+
292
+
let of_int = function
293
+
| -32700 -> `Parse_error
294
+
| -32600 -> `Invalid_request
295
+
| -32601 -> `Method_not_found
296
+
| -32602 -> `Invalid_params
297
+
| -32603 -> `Internal_error
298
+
| n -> `Custom n
299
+
300
+
let json : t Json.codec = map ~kind:"ErrorCode" ~dec:of_int ~enc:to_int int
301
+
end
302
+
303
+
type error_detail = { code : int; message : string; data : Json.t option }
304
+
305
+
let error_detail ~code ~message ?data () =
306
+
{ code = Error_code.to_int code; message; data }
307
+
308
+
let error_detail_jsont : error_detail Json.codec =
309
+
let make code message data = { code; message; data } in
310
+
Object.map ~kind:"ErrorDetail" make
311
+
|> Object.member "code" int ~enc:(fun e -> e.code)
312
+
|> Object.member "message" string ~enc:(fun e -> e.message)
313
+
|> Object.opt_member "data" Value.t ~enc:(fun e -> e.data)
314
+
|> Object.seal
315
+
316
+
type success = {
317
+
subtype : [ `Success ];
318
+
request_id : string;
319
+
response : Json.t option;
320
+
unknown : Unknown.t;
321
+
}
322
+
323
+
type error = {
324
+
subtype : [ `Error ];
325
+
request_id : string;
326
+
error : error_detail;
327
+
unknown : Unknown.t;
328
+
}
329
+
330
+
type t = Success of success | Error of error
331
+
332
+
let success ~request_id ?response ?(unknown = Unknown.empty) () =
333
+
Success { subtype = `Success; request_id; response; unknown }
334
+
335
+
let error ~request_id ~error ?(unknown = Unknown.empty) () =
336
+
Error { subtype = `Error; request_id; error; unknown }
337
+
338
+
(* Individual record codecs *)
339
+
let success_jsont : success Json.codec =
340
+
let make request_id response (unknown : Unknown.t) : success =
341
+
{ subtype = `Success; request_id; response; unknown }
342
+
in
343
+
Object.map ~kind:"Success" make
344
+
|> Object.member "request_id" string ~enc:(fun (r : success) ->
345
+
r.request_id)
346
+
|> Object.opt_member "response" Value.t ~enc:(fun (r : success) ->
347
+
r.response)
348
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : success) -> r.unknown)
349
+
|> Object.seal
350
+
351
+
let error_jsont : error Json.codec =
352
+
let make request_id error (unknown : Unknown.t) : error =
353
+
{ subtype = `Error; request_id; error; unknown }
354
+
in
355
+
Object.map ~kind:"Error" make
356
+
|> Object.member "request_id" string ~enc:(fun (r : error) -> r.request_id)
357
+
|> Object.member "error" error_detail_jsont ~enc:(fun (r : error) ->
358
+
r.error)
359
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : error) -> r.unknown)
360
+
|> Object.seal
361
+
362
+
(* Main variant codec using subtype discriminator *)
363
+
let json : t Json.codec =
364
+
let case_success =
365
+
Object.Case.map "success" success_jsont ~dec:(fun v -> Success v)
366
+
in
367
+
let case_error =
368
+
Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
369
+
in
370
+
371
+
let enc_case = function
372
+
| Success v -> Object.Case.value case_success v
373
+
| Error v -> Object.Case.value case_error v
374
+
in
375
+
376
+
let cases = Object.Case.[ make case_success; make case_error ] in
377
+
378
+
Object.map ~kind:"Response" Fun.id
379
+
|> Object.case_member "subtype" string ~enc:Fun.id ~enc_case cases
380
+
~tag_to_string:Fun.id ~tag_compare:String.compare
381
+
|> Object.seal
382
+
end
383
+
384
+
type control_request = {
385
+
type_ : [ `Control_request ];
11
386
request_id : string;
12
-
subtype : string;
13
-
data : Jsont.json;
387
+
request : Request.t;
388
+
unknown : Unknown.t;
389
+
}
390
+
391
+
type control_response = {
392
+
type_ : [ `Control_response ];
393
+
response : Response.t;
14
394
unknown : Unknown.t;
15
395
}
16
396
17
-
let jsont =
18
-
Jsont.Object.map ~kind:"Control" (fun request_id subtype data unknown ->
19
-
{ request_id; subtype; data; unknown })
20
-
|> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun t -> t.request_id)
21
-
|> Jsont.Object.mem "subtype" Jsont.string ~enc:(fun t -> t.subtype)
22
-
|> Jsont.Object.mem "data" Jsont.json ~enc:(fun t -> t.data)
23
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun t -> t.unknown)
24
-
|> Jsont.Object.finish
397
+
type t = Request of control_request | Response of control_response
25
398
26
-
let create ~request_id ~subtype ~data =
27
-
{ request_id; subtype; data; unknown = Unknown.empty }
399
+
let request ~request_id ~request ?(unknown = Unknown.empty) () =
400
+
Request { type_ = `Control_request; request_id; request; unknown }
28
401
29
-
let request_id t = t.request_id
30
-
let subtype t = t.subtype
31
-
let data t = t.data
402
+
let response ~response ?(unknown = Unknown.empty) () =
403
+
Response { type_ = `Control_response; response; unknown }
32
404
33
-
let to_json t =
34
-
Jsont_bytesrw.encode_string ~format:Jsont.Minify jsont t
35
-
|> Err.get_ok ~msg:"Control.to_json: "
36
-
|> Jsont_bytesrw.decode_string' Jsont.json
37
-
|> Result.map_error Jsont.Error.to_string
38
-
|> Err.get_ok ~msg:"Control.to_json: "
405
+
(* Individual record codecs *)
406
+
let control_request_jsont : control_request Json.codec =
407
+
let make request_id request (unknown : Unknown.t) : control_request =
408
+
{ type_ = `Control_request; request_id; request; unknown }
409
+
in
410
+
Object.map ~kind:"ControlRequest" make
411
+
|> Object.member "request_id" string ~enc:(fun (r : control_request) ->
412
+
r.request_id)
413
+
|> Object.member "request" Request.json ~enc:(fun (r : control_request) ->
414
+
r.request)
415
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : control_request) ->
416
+
r.unknown)
417
+
|> Object.seal
39
418
40
-
let of_json json =
41
-
Jsont_bytesrw.encode_string ~format:Jsont.Minify Jsont.json json
42
-
|> Err.get_ok' ~msg:"Control.of_json: "
43
-
|> Jsont_bytesrw.decode_string jsont
44
-
|> Err.get_ok' ~msg:"Control.of_json: "
419
+
let control_response_jsont : control_response Json.codec =
420
+
let make response (unknown : Unknown.t) : control_response =
421
+
{ type_ = `Control_response; response; unknown }
422
+
in
423
+
Object.map ~kind:"ControlResponse" make
424
+
|> Object.member "response" Response.json ~enc:(fun (r : control_response) ->
425
+
r.response)
426
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : control_response) ->
427
+
r.unknown)
428
+
|> Object.seal
45
429
46
-
let log_received t =
47
-
Log.debug (fun m ->
48
-
m "Received control message: %a" (Jsont.pp_value jsont ()) t)
430
+
(* Main variant codec using type discriminator *)
431
+
let json : t Json.codec =
432
+
let case_request =
433
+
Object.Case.map "control_request" control_request_jsont ~dec:(fun v ->
434
+
Request v)
435
+
in
436
+
let case_response =
437
+
Object.Case.map "control_response" control_response_jsont ~dec:(fun v ->
438
+
Response v)
439
+
in
49
440
50
-
let log_sending t =
441
+
let enc_case = function
442
+
| Request v -> Object.Case.value case_request v
443
+
| Response v -> Object.Case.value case_response v
444
+
in
445
+
446
+
let cases = Object.Case.[ make case_request; make case_response ] in
447
+
448
+
Object.map ~kind:"Control" Fun.id
449
+
|> Object.case_member "type" string ~enc:Fun.id ~enc_case cases
450
+
~tag_to_string:Fun.id ~tag_compare:String.compare
451
+
|> Object.seal
452
+
453
+
let pp ppf t = Json.pp_value json ppf t
454
+
455
+
let log_request req =
456
+
Log.debug (fun m -> m "control request: %a" (Json.pp_value Request.json) req)
457
+
458
+
let log_response resp =
51
459
Log.debug (fun m ->
52
-
m "Sending control message: %a" (Jsont.pp_value jsont ()) t)
460
+
m "control response: %a" (Json.pp_value Response.json) resp)
461
+
462
+
(** Server information *)
463
+
module Server_info = struct
464
+
type t = {
465
+
version : string;
466
+
capabilities : string list;
467
+
commands : string list;
468
+
output_styles : string list;
469
+
unknown : Unknown.t;
470
+
}
471
+
472
+
let create ~version ~capabilities ~commands ~output_styles
473
+
?(unknown = Unknown.empty) () =
474
+
{ version; capabilities; commands; output_styles; unknown }
475
+
476
+
let version t = t.version
477
+
let capabilities t = t.capabilities
478
+
let commands t = t.commands
479
+
let output_styles t = t.output_styles
480
+
let unknown t = t.unknown
481
+
482
+
let json : t Json.codec =
483
+
let make version capabilities commands output_styles (unknown : Unknown.t) :
484
+
t =
485
+
{ version; capabilities; commands; output_styles; unknown }
486
+
in
487
+
Object.map ~kind:"ServerInfo" make
488
+
|> Object.member "version" string ~enc:(fun (r : t) -> r.version)
489
+
|> Object.member "capabilities" (list string)
490
+
~enc:(fun (r : t) -> r.capabilities)
491
+
~dec_absent:[]
492
+
|> Object.member "commands" (list string)
493
+
~enc:(fun (r : t) -> r.commands)
494
+
~dec_absent:[]
495
+
|> Object.member "outputStyles" (list string)
496
+
~enc:(fun (r : t) -> r.output_styles)
497
+
~dec_absent:[]
498
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : t) -> r.unknown)
499
+
|> Object.seal
500
+
end
+366
-29
lib/control.mli
+366
-29
lib/control.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Control messages for Claude session management.
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}
7
55
8
-
Control messages are used to manage the interaction flow with Claude,
9
-
including session control, cancellation requests, and other operational
10
-
commands. *)
56
+
See {!Client.set_permission_mode}, {!Client.set_model}, and
57
+
{!Client.server_info} for high-level APIs that use this protocol. *)
11
58
12
59
val src : Logs.Src.t
13
-
(** The log source for control message operations *)
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 : Json.t;
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 * Json.t) 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 : Json.t;
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 : Json.t;
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:Json.t ->
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 * Json.t) 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:Json.t ->
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:Json.t -> ?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 json : t Json.codec
177
+
(** [json] is the json codec for requests. Use [Json.pp_value json] 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 json : t Json.codec
203
+
(** [json] 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 : Json.t 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:Json.t ->
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 Json.codec
231
+
(** [error_detail_jsont] is the Jsont codec for error details. *)
232
+
233
+
type success = {
234
+
subtype : [ `Success ];
235
+
request_id : string;
236
+
response : Json.t 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:Json.t -> ?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 json : t Json.codec
263
+
(** [json] is the json codec for responses. Use [Json.pp_value json] for
264
+
pretty-printing. *)
265
+
end
266
+
267
+
(** {1 Control Messages} *)
14
268
15
-
type t
16
-
(** The type of control messages. *)
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. *)
17
283
18
-
val jsont : t Jsont.t
19
-
(** [jsont] is the jsont codec for control messages. *)
284
+
val control_request_jsont : control_request Json.codec
285
+
(** [control_request_jsont] is the json codec for control request messages. *)
20
286
21
-
val create : request_id:string -> subtype:string -> data:Jsont.json -> t
22
-
(** [create ~request_id ~subtype ~data] creates a new control message.
23
-
@param request_id Unique identifier for this control request
24
-
@param subtype The specific type of control message
25
-
@param data Additional JSON data for the control message *)
287
+
val control_response_jsont : control_response Json.codec
288
+
(** [control_response_jsont] is the json codec for control response messages. *)
26
289
27
-
val request_id : t -> string
28
-
(** [request_id t] returns the unique request identifier. *)
290
+
type t =
291
+
| Request of control_request
292
+
| Response of control_response (** The type of SDK control messages. *)
29
293
30
-
val subtype : t -> string
31
-
(** [subtype t] returns the control message subtype. *)
294
+
val request :
295
+
request_id:string -> request:Request.t -> ?unknown:Unknown.t -> unit -> t
296
+
(** [request ~request_id ~request ?unknown ()] creates a control request
297
+
message. *)
32
298
33
-
val data : t -> Jsont.json
34
-
(** [data t] returns the additional data associated with the control message. *)
299
+
val response : response:Response.t -> ?unknown:Unknown.t -> unit -> t
300
+
(** [response ~response ?unknown ()] creates a control response message. *)
35
301
36
-
val to_json : t -> Jsont.json
37
-
(** [to_json t] converts the control message to its JSON representation. *)
302
+
val json : t Json.codec
303
+
(** [json] is the json codec for control messages. Use [Json.pp_value json] for
304
+
pretty-printing. *)
38
305
39
-
val of_json : Jsont.json -> t
40
-
(** [of_json json] parses a control message from JSON.
41
-
@raise Invalid_argument if the JSON is not a valid control message. *)
306
+
val pp : Format.formatter -> t -> unit
307
+
(** [pp ppf t] pretty-prints the SDK control message. *)
42
308
43
309
(** {1 Logging} *)
44
310
45
-
val log_received : t -> unit
46
-
(** [log_received t] logs that a control message was received. *)
311
+
val log_request : Request.t -> unit
312
+
(** [log_request req] logs an SDK control request. *)
313
+
314
+
val log_response : Response.t -> unit
315
+
(** [log_response resp] logs an SDK control response. *)
316
+
317
+
(** {1 Server Information}
47
318
48
-
val log_sending : t -> unit
49
-
(** [log_sending t] logs that a control message is being sent. *)
319
+
Server information provides metadata about the Claude CLI server, including
320
+
version, capabilities, available commands, and output styles.
321
+
322
+
{2 Use Cases}
323
+
324
+
- Feature detection: Check if specific capabilities are available
325
+
- Version compatibility: Ensure minimum version requirements
326
+
- Debugging: Log server information for troubleshooting
327
+
- Dynamic adaptation: Adjust SDK behavior based on capabilities
328
+
329
+
{2 Example}
330
+
331
+
{[
332
+
let info = Client.server_info client in
333
+
Printf.printf "Claude CLI version: %s\n" (Server_info.version info);
334
+
335
+
if List.mem "structured-output" (Server_info.capabilities info) then
336
+
Printf.printf "Structured output is supported\n"
337
+
else Printf.printf "Structured output not available\n"
338
+
]} *)
339
+
340
+
module Server_info : sig
341
+
(** Server information and capabilities. *)
342
+
343
+
type t = {
344
+
version : string; (** Server version string (e.g., "2.0.0") *)
345
+
capabilities : string list;
346
+
(** Available server capabilities (e.g., "hooks", "structured-output")
347
+
*)
348
+
commands : string list; (** Available CLI commands *)
349
+
output_styles : string list;
350
+
(** Supported output formats (e.g., "json", "stream-json") *)
351
+
unknown : Unknown.t; (** Unknown fields for forward compatibility *)
352
+
}
353
+
(** Server metadata and capabilities.
354
+
355
+
This information is useful for feature detection and debugging. *)
356
+
357
+
val create :
358
+
version:string ->
359
+
capabilities:string list ->
360
+
commands:string list ->
361
+
output_styles:string list ->
362
+
?unknown:Unknown.t ->
363
+
unit ->
364
+
t
365
+
(** [create ~version ~capabilities ~commands ~output_styles ?unknown ()]
366
+
creates server info. *)
367
+
368
+
val version : t -> string
369
+
(** [version t] returns the server version. *)
370
+
371
+
val capabilities : t -> string list
372
+
(** [capabilities t] returns the server capabilities. *)
373
+
374
+
val commands : t -> string list
375
+
(** [commands t] returns available commands. *)
376
+
377
+
val output_styles : t -> string list
378
+
(** [output_styles t] returns available output styles. *)
379
+
380
+
val unknown : t -> Unknown.t
381
+
(** [unknown t] returns the unknown fields. *)
382
+
383
+
val json : t Json.codec
384
+
(** [json] is the json codec for server info. Use [Json.pp_value json] for
385
+
pretty-printing. *)
386
+
end
+1
-1
lib/dune
+1
-1
lib/dune
+65
lib/error.ml
+65
lib/error.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/error.mli
+62
lib/error.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. *)
+22
-24
lib/handler.mli
+22
-24
lib/handler.mli
···
16
16
methods you care about:
17
17
18
18
{[
19
-
let my_handler =
20
-
object
21
-
inherit Claude.Handler.default
22
-
method! on_text t = print_endline (Response.Text.content t)
19
+
let my_handler =
20
+
object
21
+
inherit Claude.Handler.default
22
+
method! on_text t = print_endline (Response.Text.content t)
23
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
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
28
]}
29
29
30
30
For compile-time guarantees that all events are handled, inherit from
···
87
87
methods you need:
88
88
89
89
{[
90
-
let handler =
91
-
object
92
-
inherit Claude.Handler.default
93
-
94
-
method! on_text t =
95
-
Printf.printf "Text: %s\n" (Response.Text.content t)
96
-
end
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
97
95
]}
98
96
99
97
Methods you don't override will simply be ignored, making this ideal for
···
149
147
150
148
Example:
151
149
{[
152
-
let handler =
153
-
object
154
-
inherit Claude.Handler.default
155
-
method! on_text t = print_endline (Response.Text.content t)
156
-
end
157
-
in
158
-
dispatch handler (Response.Text text_event)
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)
159
157
]} *)
160
158
161
159
val dispatch_all : #handler -> Response.t list -> unit
···
166
164
may be more convenient:
167
165
168
166
{[
169
-
let responses = Client.receive_all client in
170
-
dispatch_all handler responses
167
+
let responses = Client.receive_all client in
168
+
dispatch_all handler responses
171
169
]} *)
+325
-337
lib/hooks.ml
+325
-337
lib/hooks.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
+
open Json.Codec
7
+
6
8
let src = Logs.Src.create "claude.hooks" ~doc:"Claude hooks system"
7
9
8
10
module Log = (val Logs.src_log src : Logs.LOG)
9
11
10
-
(** {1 PreToolUse Hook} *)
12
+
(** {1 Hook Events} *)
13
+
14
+
type event =
15
+
| Pre_tool_use
16
+
| Post_tool_use
17
+
| User_prompt_submit
18
+
| Stop
19
+
| Subagent_stop
20
+
| Pre_compact
21
+
22
+
let event_to_string = function
23
+
| Pre_tool_use -> "PreToolUse"
24
+
| Post_tool_use -> "PostToolUse"
25
+
| User_prompt_submit -> "UserPromptSubmit"
26
+
| Stop -> "Stop"
27
+
| Subagent_stop -> "SubagentStop"
28
+
| Pre_compact -> "PreCompact"
29
+
30
+
let event_of_string = function
31
+
| "PreToolUse" -> Pre_tool_use
32
+
| "PostToolUse" -> Post_tool_use
33
+
| "UserPromptSubmit" -> User_prompt_submit
34
+
| "Stop" -> Stop
35
+
| "SubagentStop" -> Subagent_stop
36
+
| "PreCompact" -> Pre_compact
37
+
| s -> raise (Invalid_argument (Fmt.str "Unknown hook event: %s" s))
38
+
39
+
let event_jsont : event Json.codec =
40
+
enum
41
+
[
42
+
("PreToolUse", Pre_tool_use);
43
+
("PostToolUse", Post_tool_use);
44
+
("UserPromptSubmit", User_prompt_submit);
45
+
("Stop", Stop);
46
+
("SubagentStop", Subagent_stop);
47
+
("PreCompact", Pre_compact);
48
+
]
49
+
50
+
(** {1 Decision} *)
51
+
52
+
type decision = Continue | Block
53
+
54
+
let decision_jsont : decision Json.codec =
55
+
enum [ ("continue", Continue); ("block", Block) ]
56
+
57
+
(** {1 Pre_tool_use Hook} *)
11
58
12
-
module PreToolUse = struct
59
+
module Pre_tool_use = struct
13
60
type input = {
14
61
session_id : string;
15
62
transcript_path : string;
···
17
64
tool_input : Tool_input.t;
18
65
}
19
66
67
+
let input_jsont : input Json.codec =
68
+
let make session_id transcript_path tool_name tool_input _unknown =
69
+
{
70
+
session_id;
71
+
transcript_path;
72
+
tool_name;
73
+
tool_input = Tool_input.of_json tool_input;
74
+
}
75
+
in
76
+
Object.map ~kind:"PreToolUseInput" make
77
+
|> Object.member "session_id" string ~enc:(fun i -> i.session_id)
78
+
|> Object.member "transcript_path" string ~enc:(fun i -> i.transcript_path)
79
+
|> Object.member "tool_name" string ~enc:(fun i -> i.tool_name)
80
+
|> Object.member "tool_input" Value.t ~enc:(fun i ->
81
+
Tool_input.to_json i.tool_input)
82
+
|> Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
83
+
|> Object.seal
84
+
20
85
type decision = Allow | Deny | Ask
86
+
87
+
let decision_jsont : decision Json.codec =
88
+
enum [ ("allow", Allow); ("deny", Deny); ("ask", Ask) ]
21
89
22
90
type output = {
23
91
decision : decision option;
···
32
100
let ask ?reason () = { decision = Some Ask; reason; updated_input = None }
33
101
let continue () = { decision = None; reason = None; updated_input = None }
34
102
35
-
type callback = input -> output
36
-
37
-
let input_of_proto proto =
38
-
{
39
-
session_id = Proto.Hooks.PreToolUse.Input.session_id proto;
40
-
transcript_path = Proto.Hooks.PreToolUse.Input.transcript_path proto;
41
-
tool_name = Proto.Hooks.PreToolUse.Input.tool_name proto;
42
-
tool_input =
43
-
Tool_input.of_json (Proto.Hooks.PreToolUse.Input.tool_input proto);
44
-
}
103
+
let output_jsont : output Json.codec =
104
+
let make _hook_event_name decision reason updated_input _unknown =
105
+
{
106
+
decision;
107
+
reason;
108
+
updated_input = Option.map Tool_input.of_json updated_input;
109
+
}
110
+
in
111
+
Object.map ~kind:"PreToolUseOutput" make
112
+
|> Object.member "hookEventName" string ~enc:(fun _ -> "PreToolUse")
113
+
|> Object.opt_member "permissionDecision" decision_jsont ~enc:(fun o ->
114
+
o.decision)
115
+
|> Object.opt_member "permissionDecisionReason" string ~enc:(fun o ->
116
+
o.reason)
117
+
|> Object.opt_member "updatedInput" Value.t ~enc:(fun o ->
118
+
Option.map Tool_input.to_json o.updated_input)
119
+
|> Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
120
+
|> Object.seal
45
121
46
-
let output_to_proto output =
47
-
match output.decision with
48
-
| None -> Proto.Hooks.PreToolUse.Output.continue ()
49
-
| Some Allow ->
50
-
let updated_input =
51
-
Option.map Tool_input.to_json output.updated_input
52
-
in
53
-
Proto.Hooks.PreToolUse.Output.allow ?reason:output.reason ?updated_input
54
-
()
55
-
| Some Deny -> Proto.Hooks.PreToolUse.Output.deny ?reason:output.reason ()
56
-
| Some Ask -> Proto.Hooks.PreToolUse.Output.ask ?reason:output.reason ()
122
+
type callback = input -> output
57
123
end
58
124
59
-
(** {1 PostToolUse Hook} *)
125
+
(** {1 Post_tool_use Hook} *)
60
126
61
-
module PostToolUse = struct
127
+
module Post_tool_use = struct
62
128
type input = {
63
129
session_id : string;
64
130
transcript_path : string;
65
131
tool_name : string;
66
132
tool_input : Tool_input.t;
67
-
tool_response : Jsont.json;
133
+
tool_response : Json.t;
68
134
}
69
135
136
+
let input_jsont : input Json.codec =
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
+
Object.map ~kind:"PostToolUseInput" make
148
+
|> Object.member "session_id" string ~enc:(fun i -> i.session_id)
149
+
|> Object.member "transcript_path" string ~enc:(fun i -> i.transcript_path)
150
+
|> Object.member "tool_name" string ~enc:(fun i -> i.tool_name)
151
+
|> Object.member "tool_input" Value.t ~enc:(fun i ->
152
+
Tool_input.to_json i.tool_input)
153
+
|> Object.member "tool_response" Value.t ~enc:(fun i -> i.tool_response)
154
+
|> Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
155
+
|> Object.seal
156
+
70
157
type output = {
71
158
block : bool;
72
159
reason : string option;
···
79
166
let block ?reason ?additional_context () =
80
167
{ block = true; reason; additional_context }
81
168
82
-
type callback = input -> output
169
+
let output_jsont : output Json.codec =
170
+
let make _hook_event_name decision reason additional_context _unknown =
171
+
{
172
+
block = (match decision with Some Block -> true | _ -> false);
173
+
reason;
174
+
additional_context;
175
+
}
176
+
in
177
+
Object.map ~kind:"PostToolUseOutput" make
178
+
|> Object.member "hookEventName" string ~enc:(fun _ -> "PostToolUse")
179
+
|> Object.opt_member "decision" decision_jsont ~enc:(fun o ->
180
+
if o.block then Some Block else None)
181
+
|> Object.opt_member "reason" string ~enc:(fun o -> o.reason)
182
+
|> Object.opt_member "additionalContext" string ~enc:(fun o ->
183
+
o.additional_context)
184
+
|> Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
185
+
|> Object.seal
83
186
84
-
let input_of_proto proto =
85
-
{
86
-
session_id = Proto.Hooks.PostToolUse.Input.session_id proto;
87
-
transcript_path = Proto.Hooks.PostToolUse.Input.transcript_path proto;
88
-
tool_name = Proto.Hooks.PostToolUse.Input.tool_name proto;
89
-
tool_input =
90
-
Tool_input.of_json (Proto.Hooks.PostToolUse.Input.tool_input proto);
91
-
tool_response = Proto.Hooks.PostToolUse.Input.tool_response proto;
92
-
}
93
-
94
-
let output_to_proto output =
95
-
if output.block then
96
-
Proto.Hooks.PostToolUse.Output.block ?reason:output.reason
97
-
?additional_context:output.additional_context ()
98
-
else
99
-
Proto.Hooks.PostToolUse.Output.continue
100
-
?additional_context:output.additional_context ()
187
+
type callback = input -> output
101
188
end
102
189
103
-
(** {1 UserPromptSubmit Hook} *)
190
+
(** {1 User_prompt_submit Hook} *)
104
191
105
-
module UserPromptSubmit = struct
192
+
module User_prompt_submit = struct
106
193
type input = {
107
194
session_id : string;
108
195
transcript_path : string;
109
196
prompt : string;
110
197
}
111
198
199
+
let input_jsont : input Json.codec =
200
+
let make session_id transcript_path prompt _unknown =
201
+
{ session_id; transcript_path; prompt }
202
+
in
203
+
Object.map ~kind:"UserPromptSubmitInput" make
204
+
|> Object.member "session_id" string ~enc:(fun i -> i.session_id)
205
+
|> Object.member "transcript_path" string ~enc:(fun i -> i.transcript_path)
206
+
|> Object.member "prompt" string ~enc:(fun i -> i.prompt)
207
+
|> Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
208
+
|> Object.seal
209
+
112
210
type output = {
113
211
block : bool;
114
212
reason : string option;
···
119
217
{ block = false; reason = None; additional_context }
120
218
121
219
let block ?reason () = { block = true; reason; additional_context = None }
220
+
221
+
let output_jsont : output Json.codec =
222
+
let make _hook_event_name decision reason additional_context _unknown =
223
+
{
224
+
block = (match decision with Some Block -> true | _ -> false);
225
+
reason;
226
+
additional_context;
227
+
}
228
+
in
229
+
Object.map ~kind:"UserPromptSubmitOutput" make
230
+
|> Object.member "hookEventName" string ~enc:(fun _ -> "UserPromptSubmit")
231
+
|> Object.opt_member "decision" decision_jsont ~enc:(fun o ->
232
+
if o.block then Some Block else None)
233
+
|> Object.opt_member "reason" string ~enc:(fun o -> o.reason)
234
+
|> Object.opt_member "additionalContext" string ~enc:(fun o ->
235
+
o.additional_context)
236
+
|> Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
237
+
|> Object.seal
122
238
123
239
type callback = input -> output
124
-
125
-
let input_of_proto proto =
126
-
{
127
-
session_id = Proto.Hooks.UserPromptSubmit.Input.session_id proto;
128
-
transcript_path = Proto.Hooks.UserPromptSubmit.Input.transcript_path proto;
129
-
prompt = Proto.Hooks.UserPromptSubmit.Input.prompt proto;
130
-
}
131
-
132
-
let output_to_proto output =
133
-
if output.block then
134
-
Proto.Hooks.UserPromptSubmit.Output.block ?reason:output.reason ()
135
-
else
136
-
Proto.Hooks.UserPromptSubmit.Output.continue
137
-
?additional_context:output.additional_context ()
138
240
end
139
241
140
242
(** {1 Stop Hook} *)
···
146
248
stop_hook_active : bool;
147
249
}
148
250
251
+
let input_jsont : input Json.codec =
252
+
let make session_id transcript_path stop_hook_active _unknown =
253
+
{ session_id; transcript_path; stop_hook_active }
254
+
in
255
+
Object.map ~kind:"StopInput" make
256
+
|> Object.member "session_id" string ~enc:(fun i -> i.session_id)
257
+
|> Object.member "transcript_path" string ~enc:(fun i -> i.transcript_path)
258
+
|> Object.member "stop_hook_active" bool ~enc:(fun i -> i.stop_hook_active)
259
+
|> Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
260
+
|> Object.seal
261
+
149
262
type output = { block : bool; reason : string option }
150
263
151
264
let continue () = { block = false; reason = None }
152
265
let block ?reason () = { block = true; reason }
153
266
154
-
type callback = input -> output
267
+
let output_jsont_with_event_name event_name : output Json.codec =
268
+
let make _hook_event_name decision reason _unknown =
269
+
{
270
+
block = (match decision with Some Block -> true | _ -> false);
271
+
reason;
272
+
}
273
+
in
274
+
Object.map ~kind:(event_name ^ "Output") make
275
+
|> Object.member "hookEventName" string ~enc:(fun _ -> event_name)
276
+
|> Object.opt_member "decision" decision_jsont ~enc:(fun o ->
277
+
if o.block then Some Block else None)
278
+
|> Object.opt_member "reason" string ~enc:(fun o -> o.reason)
279
+
|> Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
280
+
|> Object.seal
155
281
156
-
let input_of_proto proto =
157
-
{
158
-
session_id = Proto.Hooks.Stop.Input.session_id proto;
159
-
transcript_path = Proto.Hooks.Stop.Input.transcript_path proto;
160
-
stop_hook_active = Proto.Hooks.Stop.Input.stop_hook_active proto;
161
-
}
282
+
let output_jsont = output_jsont_with_event_name "Stop"
162
283
163
-
let output_to_proto output =
164
-
if output.block then Proto.Hooks.Stop.Output.block ?reason:output.reason ()
165
-
else Proto.Hooks.Stop.Output.continue ()
284
+
type callback = input -> output
166
285
end
167
286
168
-
(** {1 SubagentStop Hook} *)
287
+
(** {1 Subagent_stop Hook} *)
169
288
170
-
module SubagentStop = struct
289
+
module Subagent_stop = struct
171
290
type input = Stop.input
172
291
type output = Stop.output
173
292
174
293
let continue = Stop.continue
175
294
let block = Stop.block
295
+
let input_jsont = Stop.input_jsont
296
+
let output_jsont = Stop.output_jsont_with_event_name "SubagentStop"
176
297
177
298
type callback = input -> output
178
-
179
-
let input_of_proto = Stop.input_of_proto
180
-
181
-
(* Since Proto.Hooks.SubagentStop.Output.t = Proto.Hooks.Stop.Output.t,
182
-
we can use Stop.output_to_proto directly *)
183
-
let output_to_proto = Stop.output_to_proto
184
299
end
185
300
186
-
(** {1 PreCompact Hook} *)
301
+
(** {1 Pre_compact Hook} *)
187
302
188
-
module PreCompact = struct
303
+
module Pre_compact = struct
189
304
type input = { session_id : string; transcript_path : string }
190
-
type callback = input -> unit
191
305
192
-
let input_of_proto proto =
193
-
{
194
-
session_id = Proto.Hooks.PreCompact.Input.session_id proto;
195
-
transcript_path = Proto.Hooks.PreCompact.Input.transcript_path proto;
196
-
}
306
+
let input_jsont : input Json.codec =
307
+
let make session_id transcript_path _unknown =
308
+
{ session_id; transcript_path }
309
+
in
310
+
Object.map ~kind:"PreCompactInput" make
311
+
|> Object.member "session_id" string ~enc:(fun i -> i.session_id)
312
+
|> Object.member "transcript_path" string ~enc:(fun i -> i.transcript_path)
313
+
|> Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
314
+
|> Object.seal
315
+
316
+
type callback = input -> unit
197
317
end
198
318
319
+
(** {1 Generic Hook Result} *)
320
+
321
+
type result = {
322
+
decision : decision option;
323
+
system_message : string option;
324
+
hook_specific_output : Json.t option;
325
+
}
326
+
327
+
let result_jsont : result Json.codec =
328
+
let make decision system_message hook_specific_output _unknown =
329
+
{ decision; system_message; hook_specific_output }
330
+
in
331
+
Object.map ~kind:"Result" make
332
+
|> Object.opt_member "decision" decision_jsont ~enc:(fun r -> r.decision)
333
+
|> Object.opt_member "systemMessage" string ~enc:(fun r -> r.system_message)
334
+
|> Object.opt_member "hookSpecificOutput" Value.t ~enc:(fun r ->
335
+
r.hook_specific_output)
336
+
|> Object.keep_unknown Unknown.mems ~enc:(fun _ -> Unknown.empty)
337
+
|> Object.seal
338
+
339
+
let continue_result ?system_message ?hook_specific_output () =
340
+
{ decision = None; system_message; hook_specific_output }
341
+
342
+
let block_result ?system_message ?hook_specific_output () =
343
+
{ decision = Some Block; system_message; hook_specific_output }
344
+
199
345
(** {1 Hook Configuration} *)
200
346
201
-
(* Internal representation of hooks *)
202
347
type hook_entry =
203
-
| PreToolUseHook of (string option * PreToolUse.callback)
204
-
| PostToolUseHook of (string option * PostToolUse.callback)
205
-
| UserPromptSubmitHook of UserPromptSubmit.callback
206
-
| StopHook of Stop.callback
207
-
| SubagentStopHook of SubagentStop.callback
208
-
| PreCompactHook of PreCompact.callback
348
+
| Pre_tool_use_hook of (string option * Pre_tool_use.callback)
349
+
| Post_tool_use_hook of (string option * Post_tool_use.callback)
350
+
| User_prompt_submit_hook of User_prompt_submit.callback
351
+
| Stop_hook of Stop.callback
352
+
| Subagent_stop_hook of Subagent_stop.callback
353
+
| Pre_compact_hook of Pre_compact.callback
209
354
210
355
type t = hook_entry list
211
356
357
+
let pp ppf t = Fmt.pf ppf "<hooks:%d>" (List.length t)
212
358
let empty = []
213
359
214
360
let on_pre_tool_use ?pattern callback config =
215
-
PreToolUseHook (pattern, callback) :: config
361
+
Pre_tool_use_hook (pattern, callback) :: config
216
362
217
363
let on_post_tool_use ?pattern callback config =
218
-
PostToolUseHook (pattern, callback) :: config
364
+
Post_tool_use_hook (pattern, callback) :: config
219
365
220
366
let on_user_prompt_submit callback config =
221
-
UserPromptSubmitHook callback :: config
367
+
User_prompt_submit_hook callback :: config
222
368
223
-
let on_stop callback config = StopHook callback :: config
224
-
let on_subagent_stop callback config = SubagentStopHook callback :: config
225
-
let on_pre_compact callback config = PreCompactHook callback :: config
369
+
let on_stop callback config = Stop_hook callback :: config
370
+
let on_subagent_stop callback config = Subagent_stop_hook callback :: config
371
+
let on_pre_compact callback config = Pre_compact_hook callback :: config
226
372
227
373
(** {1 Internal - Conversion to Wire Format} *)
228
374
229
-
let get_callbacks config =
230
-
(* Group hooks by event type *)
231
-
let pre_tool_use_hooks = ref [] in
232
-
let post_tool_use_hooks = ref [] in
233
-
let user_prompt_submit_hooks = ref [] in
234
-
let stop_hooks = ref [] in
235
-
let subagent_stop_hooks = ref [] in
236
-
let pre_compact_hooks = ref [] in
375
+
let decode_input name codec v =
376
+
match Json.decode codec v with
377
+
| Ok input -> input
378
+
| Error err ->
379
+
let msg = Json.Error.to_string err in
380
+
Log.err (fun m -> m "%s: failed to decode input: %s" name msg);
381
+
raise (Invalid_argument (name ^ " input: " ^ msg))
237
382
383
+
let encode_output _name codec output = Json.encode codec output
384
+
385
+
let wire_callback ~name ~input_jsont ~output_jsont ~should_block callback json =
386
+
let typed_input = decode_input name input_jsont json in
387
+
let typed_output = callback typed_input in
388
+
let hook_specific_output = encode_output name output_jsont typed_output in
389
+
if should_block typed_output then block_result ~hook_specific_output ()
390
+
else continue_result ~hook_specific_output ()
391
+
392
+
let group_hooks config =
393
+
let pre_tool_use = ref [] in
394
+
let post_tool_use = ref [] in
395
+
let user_prompt_submit = ref [] in
396
+
let stop = ref [] in
397
+
let subagent_stop = ref [] in
398
+
let pre_compact = ref [] in
238
399
List.iter
239
400
(function
240
-
| PreToolUseHook (pattern, callback) ->
241
-
pre_tool_use_hooks := (pattern, callback) :: !pre_tool_use_hooks
242
-
| PostToolUseHook (pattern, callback) ->
243
-
post_tool_use_hooks := (pattern, callback) :: !post_tool_use_hooks
244
-
| UserPromptSubmitHook callback ->
245
-
user_prompt_submit_hooks :=
246
-
(None, callback) :: !user_prompt_submit_hooks
247
-
| StopHook callback -> stop_hooks := (None, callback) :: !stop_hooks
248
-
| SubagentStopHook callback ->
249
-
subagent_stop_hooks := (None, callback) :: !subagent_stop_hooks
250
-
| PreCompactHook callback ->
251
-
pre_compact_hooks := (None, callback) :: !pre_compact_hooks)
401
+
| Pre_tool_use_hook (pattern, callback) ->
402
+
pre_tool_use := (pattern, callback) :: !pre_tool_use
403
+
| Post_tool_use_hook (pattern, callback) ->
404
+
post_tool_use := (pattern, callback) :: !post_tool_use
405
+
| User_prompt_submit_hook callback ->
406
+
user_prompt_submit := (None, callback) :: !user_prompt_submit
407
+
| Stop_hook callback -> stop := (None, callback) :: !stop
408
+
| Subagent_stop_hook callback ->
409
+
subagent_stop := (None, callback) :: !subagent_stop
410
+
| Pre_compact_hook callback ->
411
+
pre_compact := (None, callback) :: !pre_compact)
252
412
config;
253
-
254
-
(* Convert each group to wire format *)
255
-
let result = [] in
413
+
( !pre_tool_use,
414
+
!post_tool_use,
415
+
!user_prompt_submit,
416
+
!stop,
417
+
!subagent_stop,
418
+
!pre_compact )
256
419
257
-
(* PreToolUse *)
258
-
let result =
259
-
if !pre_tool_use_hooks <> [] then
420
+
let add_standard_event event hooks ~name ~input_jsont ~output_jsont
421
+
~should_block result =
422
+
match hooks with
423
+
| [] -> result
424
+
| _ ->
260
425
let wire_callbacks =
261
426
List.map
262
427
(fun (pattern, callback) ->
263
-
let wire_callback json =
264
-
(* Decode JSON to Proto input *)
265
-
let proto_input =
266
-
match
267
-
Jsont.Json.decode Proto.Hooks.PreToolUse.Input.jsont json
268
-
with
269
-
| Ok input -> input
270
-
| Error msg ->
271
-
Log.err (fun m ->
272
-
m "PreToolUse: failed to decode input: %s" msg);
273
-
raise (Invalid_argument ("PreToolUse input: " ^ msg))
274
-
in
275
-
(* Convert to typed input *)
276
-
let typed_input = PreToolUse.input_of_proto proto_input in
277
-
(* Invoke user callback *)
278
-
let typed_output = callback typed_input in
279
-
(* Convert back to Proto output *)
280
-
let proto_output = PreToolUse.output_to_proto typed_output in
281
-
(* Encode as hook_specific_output *)
282
-
let hook_specific_output =
283
-
match
284
-
Jsont.Json.encode Proto.Hooks.PreToolUse.Output.jsont
285
-
proto_output
286
-
with
287
-
| Ok json -> json
288
-
| Error msg -> failwith ("PreToolUse output encoding: " ^ msg)
289
-
in
290
-
(* Return wire format result *)
291
-
Proto.Hooks.continue ~hook_specific_output ()
292
-
in
293
-
(pattern, wire_callback))
294
-
!pre_tool_use_hooks
428
+
( pattern,
429
+
wire_callback ~name ~input_jsont ~output_jsont ~should_block
430
+
callback ))
431
+
hooks
295
432
in
296
-
(Proto.Hooks.Pre_tool_use, wire_callbacks) :: result
297
-
else result
298
-
in
433
+
(event, wire_callbacks) :: result
299
434
300
-
(* PostToolUse *)
301
-
let result =
302
-
if !post_tool_use_hooks <> [] then
435
+
let add_pre_compact_event hooks result =
436
+
match hooks with
437
+
| [] -> result
438
+
| _ ->
303
439
let wire_callbacks =
304
440
List.map
305
441
(fun (pattern, callback) ->
306
442
let wire_callback json =
307
-
let proto_input =
308
-
match
309
-
Jsont.Json.decode Proto.Hooks.PostToolUse.Input.jsont json
310
-
with
311
-
| Ok input -> input
312
-
| Error msg ->
313
-
Log.err (fun m ->
314
-
m "PostToolUse: failed to decode input: %s" msg);
315
-
raise (Invalid_argument ("PostToolUse input: " ^ msg))
443
+
let typed_input =
444
+
decode_input "PreCompact" Pre_compact.input_jsont json
316
445
in
317
-
let typed_input = PostToolUse.input_of_proto proto_input in
318
-
let typed_output = callback typed_input in
319
-
let proto_output = PostToolUse.output_to_proto typed_output in
320
-
let hook_specific_output =
321
-
match
322
-
Jsont.Json.encode Proto.Hooks.PostToolUse.Output.jsont
323
-
proto_output
324
-
with
325
-
| Ok json -> json
326
-
| Error msg -> failwith ("PostToolUse output encoding: " ^ msg)
327
-
in
328
-
if typed_output.block then
329
-
Proto.Hooks.block ~hook_specific_output ()
330
-
else Proto.Hooks.continue ~hook_specific_output ()
331
-
in
332
-
(pattern, wire_callback))
333
-
!post_tool_use_hooks
334
-
in
335
-
(Proto.Hooks.Post_tool_use, wire_callbacks) :: result
336
-
else result
337
-
in
338
-
339
-
(* UserPromptSubmit *)
340
-
let result =
341
-
if !user_prompt_submit_hooks <> [] then
342
-
let wire_callbacks =
343
-
List.map
344
-
(fun (pattern, callback) ->
345
-
let wire_callback json =
346
-
let proto_input =
347
-
match
348
-
Jsont.Json.decode Proto.Hooks.UserPromptSubmit.Input.jsont
349
-
json
350
-
with
351
-
| Ok input -> input
352
-
| Error msg ->
353
-
Log.err (fun m ->
354
-
m "UserPromptSubmit: failed to decode input: %s" msg);
355
-
raise (Invalid_argument ("UserPromptSubmit input: " ^ msg))
356
-
in
357
-
let typed_input = UserPromptSubmit.input_of_proto proto_input in
358
-
let typed_output = callback typed_input in
359
-
let proto_output =
360
-
UserPromptSubmit.output_to_proto typed_output
361
-
in
362
-
let hook_specific_output =
363
-
match
364
-
Jsont.Json.encode Proto.Hooks.UserPromptSubmit.Output.jsont
365
-
proto_output
366
-
with
367
-
| Ok json -> json
368
-
| Error msg ->
369
-
failwith ("UserPromptSubmit output encoding: " ^ msg)
370
-
in
371
-
if typed_output.block then
372
-
Proto.Hooks.block ~hook_specific_output ()
373
-
else Proto.Hooks.continue ~hook_specific_output ()
374
-
in
375
-
(pattern, wire_callback))
376
-
!user_prompt_submit_hooks
377
-
in
378
-
(Proto.Hooks.User_prompt_submit, wire_callbacks) :: result
379
-
else result
380
-
in
381
-
382
-
(* Stop *)
383
-
let result =
384
-
if !stop_hooks <> [] then
385
-
let wire_callbacks =
386
-
List.map
387
-
(fun (pattern, callback) ->
388
-
let wire_callback json =
389
-
let proto_input =
390
-
match Jsont.Json.decode Proto.Hooks.Stop.Input.jsont json with
391
-
| Ok input -> input
392
-
| Error msg ->
393
-
Log.err (fun m -> m "Stop: failed to decode input: %s" msg);
394
-
raise (Invalid_argument ("Stop input: " ^ msg))
395
-
in
396
-
let typed_input = Stop.input_of_proto proto_input in
397
-
let typed_output = callback typed_input in
398
-
let proto_output = Stop.output_to_proto typed_output in
399
-
let hook_specific_output =
400
-
match
401
-
Jsont.Json.encode Proto.Hooks.Stop.Output.jsont proto_output
402
-
with
403
-
| Ok json -> json
404
-
| Error msg -> failwith ("Stop output encoding: " ^ msg)
405
-
in
406
-
if typed_output.block then
407
-
Proto.Hooks.block ~hook_specific_output ()
408
-
else Proto.Hooks.continue ~hook_specific_output ()
409
-
in
410
-
(pattern, wire_callback))
411
-
!stop_hooks
412
-
in
413
-
(Proto.Hooks.Stop, wire_callbacks) :: result
414
-
else result
415
-
in
416
-
417
-
(* SubagentStop *)
418
-
let result =
419
-
if !subagent_stop_hooks <> [] then
420
-
let wire_callbacks =
421
-
List.map
422
-
(fun (pattern, callback) ->
423
-
let wire_callback json =
424
-
let proto_input =
425
-
match
426
-
Jsont.Json.decode Proto.Hooks.SubagentStop.Input.jsont json
427
-
with
428
-
| Ok input -> input
429
-
| Error msg ->
430
-
Log.err (fun m ->
431
-
m "SubagentStop: failed to decode input: %s" msg);
432
-
raise (Invalid_argument ("SubagentStop input: " ^ msg))
433
-
in
434
-
let typed_input = SubagentStop.input_of_proto proto_input in
435
-
let typed_output = callback typed_input in
436
-
let proto_output = SubagentStop.output_to_proto typed_output in
437
-
let hook_specific_output =
438
-
match
439
-
Jsont.Json.encode Proto.Hooks.SubagentStop.Output.jsont
440
-
proto_output
441
-
with
442
-
| Ok json -> json
443
-
| Error msg -> failwith ("SubagentStop output encoding: " ^ msg)
444
-
in
445
-
if typed_output.block then
446
-
Proto.Hooks.block ~hook_specific_output ()
447
-
else Proto.Hooks.continue ~hook_specific_output ()
448
-
in
449
-
(pattern, wire_callback))
450
-
!subagent_stop_hooks
451
-
in
452
-
(Proto.Hooks.Subagent_stop, wire_callbacks) :: result
453
-
else result
454
-
in
455
-
456
-
(* PreCompact *)
457
-
let result =
458
-
if !pre_compact_hooks <> [] then
459
-
let wire_callbacks =
460
-
List.map
461
-
(fun (pattern, callback) ->
462
-
let wire_callback json =
463
-
let proto_input =
464
-
match
465
-
Jsont.Json.decode Proto.Hooks.PreCompact.Input.jsont json
466
-
with
467
-
| Ok input -> input
468
-
| Error msg ->
469
-
Log.err (fun m ->
470
-
m "PreCompact: failed to decode input: %s" msg);
471
-
raise (Invalid_argument ("PreCompact input: " ^ msg))
472
-
in
473
-
let typed_input = PreCompact.input_of_proto proto_input in
474
-
(* Invoke user callback (returns unit) *)
475
446
callback typed_input;
476
-
(* PreCompact has no specific output *)
477
-
Proto.Hooks.continue ()
447
+
continue_result ()
478
448
in
479
449
(pattern, wire_callback))
480
-
!pre_compact_hooks
450
+
hooks
481
451
in
482
-
(Proto.Hooks.Pre_compact, wire_callbacks) :: result
483
-
else result
484
-
in
452
+
(Pre_compact, wire_callbacks) :: result
485
453
486
-
List.rev result
454
+
let callbacks config =
455
+
let ptu, potu, ups, st, sas, pc = group_hooks config in
456
+
[]
457
+
|> add_standard_event Pre_tool_use ptu ~name:"PreToolUse"
458
+
~input_jsont:Pre_tool_use.input_jsont
459
+
~output_jsont:Pre_tool_use.output_jsont ~should_block:(fun _ -> false)
460
+
|> add_standard_event Post_tool_use potu ~name:"PostToolUse"
461
+
~input_jsont:Post_tool_use.input_jsont
462
+
~output_jsont:Post_tool_use.output_jsont ~should_block:(fun o ->
463
+
o.Post_tool_use.block)
464
+
|> add_standard_event User_prompt_submit ups ~name:"UserPromptSubmit"
465
+
~input_jsont:User_prompt_submit.input_jsont
466
+
~output_jsont:User_prompt_submit.output_jsont ~should_block:(fun o ->
467
+
o.User_prompt_submit.block)
468
+
|> add_standard_event Stop st ~name:"Stop" ~input_jsont:Stop.input_jsont
469
+
~output_jsont:Stop.output_jsont ~should_block:(fun o -> o.Stop.block)
470
+
|> add_standard_event Subagent_stop sas ~name:"SubagentStop"
471
+
~input_jsont:Subagent_stop.input_jsont
472
+
~output_jsont:Subagent_stop.output_jsont ~should_block:(fun o ->
473
+
o.Stop.block)
474
+
|> add_pre_compact_event pc |> List.rev
+86
-208
lib/hooks.mli
+86
-208
lib/hooks.mli
···
8
8
Hooks allow you to intercept and control events in Claude Code sessions,
9
9
using fully typed OCaml values instead of raw JSON.
10
10
11
-
{1 Overview}
12
-
13
-
This module provides a high-level, type-safe interface to hooks. Each hook
14
-
type has:
15
-
- Fully typed input records using {!Tool_input.t}
16
-
- Fully typed output records
17
-
- Helper functions for common responses
18
-
- Conversion functions to/from wire format ({!Proto.Hooks})
19
-
20
11
{1 Example Usage}
21
12
22
13
{[
···
24
15
25
16
(* Block dangerous bash commands *)
26
17
let block_rm_rf input =
27
-
if input.Hooks.PreToolUse.tool_name = "Bash" then
28
-
match Tool_input.get_string input.tool_input "command" with
18
+
if input.Hooks.Pre_tool_use.tool_name = "Bash" then
19
+
match Tool_input.string input.tool_input "command" with
29
20
| Some cmd when String.contains cmd "rm -rf" ->
30
-
Hooks.PreToolUse.deny ~reason:"Dangerous command" ()
31
-
| _ -> Hooks.PreToolUse.continue ()
32
-
else Hooks.PreToolUse.continue ()
21
+
Hooks.Pre_tool_use.deny ~reason:"Dangerous command" ()
22
+
| _ -> Hooks.Pre_tool_use.continue ()
23
+
else Hooks.Pre_tool_use.continue ()
33
24
34
25
let hooks =
35
26
Hooks.empty
36
27
|> Hooks.on_pre_tool_use ~pattern:"Bash" block_rm_rf
37
28
38
29
let options = Claude.Options.create ~hooks () in
39
-
let client = Claude.Client.create ~options ~sw ~process_mgr () in
30
+
let client = Claude.Client.v ~options ~sw ~process_mgr () in
40
31
]} *)
41
32
42
33
val src : Logs.Src.t
43
-
(** The log source for hooks *)
34
+
(** The log source for hooks. *)
44
35
45
-
(** {1 Hook Types} *)
36
+
(** {1 Hook Events} *)
46
37
47
-
(** PreToolUse hook - fires before tool execution *)
48
-
module PreToolUse : sig
49
-
(** {2 Input} *)
38
+
type event =
39
+
| Pre_tool_use
40
+
| Post_tool_use
41
+
| User_prompt_submit
42
+
| Stop
43
+
| Subagent_stop
44
+
| Pre_compact
50
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 Json.codec
54
+
55
+
(** {1 Decision} *)
56
+
57
+
type decision = Continue | Block
58
+
59
+
val decision_jsont : decision Json.codec
60
+
61
+
(** {1 Hook Types} *)
62
+
63
+
(** Pre_tool_use hook - fires before tool execution. *)
64
+
module Pre_tool_use : sig
51
65
type input = {
52
66
session_id : string;
53
67
transcript_path : string;
54
68
tool_name : string;
55
69
tool_input : Tool_input.t;
56
70
}
57
-
(** Input provided to PreToolUse hooks. *)
71
+
72
+
val input_jsont : input Json.codec
58
73
59
-
(** {2 Output} *)
74
+
type decision = Allow | Deny | Ask
60
75
61
-
type decision =
62
-
| Allow
63
-
| Deny
64
-
| Ask (** Permission decision for tool usage. *)
76
+
val decision_jsont : decision Json.codec
65
77
66
78
type output = {
67
79
decision : decision option;
68
80
reason : string option;
69
81
updated_input : Tool_input.t option;
70
82
}
71
-
(** Output from PreToolUse hooks. *)
72
83
73
-
(** {2 Response Builders} *)
74
-
84
+
val output_jsont : output Json.codec
75
85
val allow : ?reason:string -> ?updated_input:Tool_input.t -> unit -> output
76
-
(** [allow ?reason ?updated_input ()] creates an allow response.
77
-
@param reason Optional explanation for allowing
78
-
@param updated_input Optional modified tool input *)
79
-
80
86
val deny : ?reason:string -> unit -> output
81
-
(** [deny ?reason ()] creates a deny response.
82
-
@param reason Optional explanation for denying *)
83
-
84
87
val ask : ?reason:string -> unit -> output
85
-
(** [ask ?reason ()] creates an ask response to prompt the user.
86
-
@param reason Optional explanation for asking *)
87
-
88
88
val continue : unit -> output
89
-
(** [continue ()] creates a continue response with no decision. *)
90
-
91
-
(** {2 Callback Type} *)
92
89
93
90
type callback = input -> output
94
-
(** Callback function type for PreToolUse hooks. *)
95
-
96
-
(** {2 Conversion Functions} *)
97
-
98
-
val input_of_proto : Proto.Hooks.PreToolUse.Input.t -> input
99
-
(** [input_of_proto proto] converts wire format input to typed input. *)
100
-
101
-
val output_to_proto : output -> Proto.Hooks.PreToolUse.Output.t
102
-
(** [output_to_proto output] converts typed output to wire format. *)
103
91
end
104
92
105
-
(** PostToolUse hook - fires after tool execution *)
106
-
module PostToolUse : sig
107
-
(** {2 Input} *)
108
-
93
+
(** Post_tool_use hook - fires after tool execution. *)
94
+
module Post_tool_use : sig
109
95
type input = {
110
96
session_id : string;
111
97
transcript_path : string;
112
98
tool_name : string;
113
99
tool_input : Tool_input.t;
114
-
tool_response : Jsont.json; (* Response varies by tool *)
100
+
tool_response : Json.t;
115
101
}
116
-
(** Input provided to PostToolUse hooks. Note: [tool_response] remains as
117
-
{!type:Jsont.json} since response schemas vary by tool. *)
118
102
119
-
(** {2 Output} *)
103
+
val input_jsont : input Json.codec
120
104
121
105
type output = {
122
106
block : bool;
123
107
reason : string option;
124
108
additional_context : string option;
125
109
}
126
-
(** Output from PostToolUse hooks. *)
127
110
128
-
(** {2 Response Builders} *)
129
-
111
+
val output_jsont : output Json.codec
130
112
val continue : ?additional_context:string -> unit -> output
131
-
(** [continue ?additional_context ()] creates a continue response.
132
-
@param additional_context Optional context to add to the transcript *)
133
-
134
113
val block : ?reason:string -> ?additional_context:string -> unit -> output
135
-
(** [block ?reason ?additional_context ()] creates a block response.
136
-
@param reason Optional explanation for blocking
137
-
@param additional_context Optional context to add to the transcript *)
138
-
139
-
(** {2 Callback Type} *)
140
114
141
115
type callback = input -> output
142
-
(** Callback function type for PostToolUse hooks. *)
143
-
144
-
(** {2 Conversion Functions} *)
145
-
146
-
val input_of_proto : Proto.Hooks.PostToolUse.Input.t -> input
147
-
(** [input_of_proto proto] converts wire format input to typed input. *)
148
-
149
-
val output_to_proto : output -> Proto.Hooks.PostToolUse.Output.t
150
-
(** [output_to_proto output] converts typed output to wire format. *)
151
116
end
152
117
153
-
(** UserPromptSubmit hook - fires when user submits a prompt *)
154
-
module UserPromptSubmit : sig
155
-
(** {2 Input} *)
156
-
118
+
(** User_prompt_submit hook - fires when user submits a prompt. *)
119
+
module User_prompt_submit : sig
157
120
type input = {
158
121
session_id : string;
159
122
transcript_path : string;
160
123
prompt : string;
161
124
}
162
-
(** Input provided to UserPromptSubmit hooks. *)
163
125
164
-
(** {2 Output} *)
126
+
val input_jsont : input Json.codec
165
127
166
128
type output = {
167
129
block : bool;
168
130
reason : string option;
169
131
additional_context : string option;
170
132
}
171
-
(** Output from UserPromptSubmit hooks. *)
172
133
173
-
(** {2 Response Builders} *)
174
-
134
+
val output_jsont : output Json.codec
175
135
val continue : ?additional_context:string -> unit -> output
176
-
(** [continue ?additional_context ()] creates a continue response.
177
-
@param additional_context Optional context to add to the transcript *)
178
-
179
136
val block : ?reason:string -> unit -> output
180
-
(** [block ?reason ()] creates a block response.
181
-
@param reason Optional explanation for blocking *)
182
-
183
-
(** {2 Callback Type} *)
184
137
185
138
type callback = input -> output
186
-
(** Callback function type for UserPromptSubmit hooks. *)
187
-
188
-
(** {2 Conversion Functions} *)
189
-
190
-
val input_of_proto : Proto.Hooks.UserPromptSubmit.Input.t -> input
191
-
(** [input_of_proto proto] converts wire format input to typed input. *)
192
-
193
-
val output_to_proto : output -> Proto.Hooks.UserPromptSubmit.Output.t
194
-
(** [output_to_proto output] converts typed output to wire format. *)
195
139
end
196
140
197
-
(** Stop hook - fires when conversation stops *)
141
+
(** Stop hook - fires when conversation stops. *)
198
142
module Stop : sig
199
-
(** {2 Input} *)
200
-
201
143
type input = {
202
144
session_id : string;
203
145
transcript_path : string;
204
146
stop_hook_active : bool;
205
147
}
206
-
(** Input provided to Stop hooks. *)
207
148
208
-
(** {2 Output} *)
149
+
val input_jsont : input Json.codec
209
150
210
151
type output = { block : bool; reason : string option }
211
-
(** Output from Stop hooks. *)
212
152
213
-
(** {2 Response Builders} *)
214
-
153
+
val output_jsont : output Json.codec
215
154
val continue : unit -> output
216
-
(** [continue ()] creates a continue response. *)
217
-
218
155
val block : ?reason:string -> unit -> output
219
-
(** [block ?reason ()] creates a block response.
220
-
@param reason Optional explanation for blocking *)
221
-
222
-
(** {2 Callback Type} *)
223
156
224
157
type callback = input -> output
225
-
(** Callback function type for Stop hooks. *)
226
-
227
-
(** {2 Conversion Functions} *)
228
-
229
-
val input_of_proto : Proto.Hooks.Stop.Input.t -> input
230
-
(** [input_of_proto proto] converts wire format input to typed input. *)
231
-
232
-
val output_to_proto : output -> Proto.Hooks.Stop.Output.t
233
-
(** [output_to_proto output] converts typed output to wire format. *)
234
158
end
235
159
236
-
(** SubagentStop hook - fires when a subagent stops *)
237
-
module SubagentStop : sig
238
-
(** {2 Input} *)
239
-
160
+
(** Subagent_stop hook - fires when a subagent stops. *)
161
+
module Subagent_stop : sig
240
162
type input = Stop.input
241
-
(** Same structure as Stop.input *)
242
-
243
-
(** {2 Output} *)
244
-
245
163
type output = Stop.output
246
-
(** Same structure as Stop.output *)
247
164
248
-
(** {2 Response Builders} *)
249
-
165
+
val input_jsont : input Json.codec
166
+
val output_jsont : output Json.codec
250
167
val continue : unit -> output
251
-
(** [continue ()] creates a continue response. *)
252
-
253
168
val block : ?reason:string -> unit -> output
254
-
(** [block ?reason ()] creates a block response.
255
-
@param reason Optional explanation for blocking *)
256
-
257
-
(** {2 Callback Type} *)
258
169
259
170
type callback = input -> output
260
-
(** Callback function type for SubagentStop hooks. *)
171
+
end
261
172
262
-
(** {2 Conversion Functions} *)
173
+
(** Pre_compact hook - fires before message compaction. *)
174
+
module Pre_compact : sig
175
+
type input = { session_id : string; transcript_path : string }
263
176
264
-
val input_of_proto : Proto.Hooks.SubagentStop.Input.t -> input
265
-
(** [input_of_proto proto] converts wire format input to typed input. *)
177
+
val input_jsont : input Json.codec
266
178
267
-
val output_to_proto : output -> Proto.Hooks.SubagentStop.Output.t
268
-
(** [output_to_proto output] converts typed output to wire format. *)
179
+
type callback = input -> unit
180
+
(** Pre_compact hooks have no output - they are notification-only. *)
269
181
end
270
182
271
-
(** PreCompact hook - fires before message compaction *)
272
-
module PreCompact : sig
273
-
(** {2 Input} *)
183
+
(** {1 Generic Hook Result} *)
274
184
275
-
type input = { session_id : string; transcript_path : string }
276
-
(** Input provided to PreCompact hooks. *)
185
+
type result = {
186
+
decision : decision option;
187
+
system_message : string option;
188
+
hook_specific_output : Json.t option;
189
+
}
277
190
278
-
(** {2 Callback Type} *)
191
+
val result_jsont : result Json.codec
279
192
280
-
type callback = input -> unit
281
-
(** Callback function type for PreCompact hooks. PreCompact hooks have no
282
-
output - they are notification-only. *)
193
+
val continue_result :
194
+
?system_message:string -> ?hook_specific_output:Json.t -> unit -> result
283
195
284
-
(** {2 Conversion Functions} *)
285
-
286
-
val input_of_proto : Proto.Hooks.PreCompact.Input.t -> input
287
-
(** [input_of_proto proto] converts wire format input to typed input. *)
288
-
end
196
+
val block_result :
197
+
?system_message:string -> ?hook_specific_output:Json.t -> unit -> result
289
198
290
199
(** {1 Hook Configuration} *)
291
200
···
294
203
295
204
Hooks are configured using a builder pattern:
296
205
{[
297
-
Hooks.empty
298
-
|> Hooks.on_pre_tool_use ~pattern:"Bash" bash_handler
299
-
|> Hooks.on_post_tool_use post_handler
206
+
Hooks.empty
207
+
|> Hooks.on_pre_tool_use ~pattern:"Bash" bash_handler
208
+
|> Hooks.on_post_tool_use post_handler
300
209
]} *)
301
210
211
+
val pp : Format.formatter -> t -> unit
302
212
val empty : t
303
-
(** [empty] is an empty hook configuration with no callbacks. *)
304
-
305
-
val on_pre_tool_use : ?pattern:string -> PreToolUse.callback -> t -> t
306
-
(** [on_pre_tool_use ?pattern callback config] adds a PreToolUse hook.
307
-
@param pattern
308
-
Optional regex pattern to match tool names (e.g., "Bash|Edit")
309
-
@param callback Function to invoke on matching events *)
310
-
311
-
val on_post_tool_use : ?pattern:string -> PostToolUse.callback -> t -> t
312
-
(** [on_post_tool_use ?pattern callback config] adds a PostToolUse hook.
313
-
@param pattern Optional regex pattern to match tool names
314
-
@param callback Function to invoke on matching events *)
315
-
316
-
val on_user_prompt_submit : UserPromptSubmit.callback -> t -> t
317
-
(** [on_user_prompt_submit callback config] adds a UserPromptSubmit hook.
318
-
@param callback Function to invoke on prompt submission *)
319
-
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
320
216
val on_stop : Stop.callback -> t -> t
321
-
(** [on_stop callback config] adds a Stop hook.
322
-
@param callback Function to invoke on conversation stop *)
323
-
324
-
val on_subagent_stop : SubagentStop.callback -> t -> t
325
-
(** [on_subagent_stop callback config] adds a SubagentStop hook.
326
-
@param callback Function to invoke on subagent stop *)
327
-
328
-
val on_pre_compact : PreCompact.callback -> t -> t
329
-
(** [on_pre_compact callback config] adds a PreCompact hook.
330
-
@param callback Function to invoke before message compaction *)
217
+
val on_subagent_stop : Subagent_stop.callback -> t -> t
218
+
val on_pre_compact : Pre_compact.callback -> t -> t
331
219
332
220
(** {1 Internal - for client use} *)
333
221
334
-
val get_callbacks :
335
-
t ->
336
-
(Proto.Hooks.event
337
-
* (string option * (Jsont.json -> Proto.Hooks.result)) list)
338
-
list
339
-
(** [get_callbacks config] returns hook configuration in format suitable for
222
+
val callbacks : t -> (event * (string option * (Json.t -> result)) list) list
223
+
(** [callbacks config] returns hook configuration in format suitable for
340
224
registration with the CLI.
341
225
342
-
This function converts typed callbacks into wire format handlers that:
343
-
- Parse JSON input using Proto.Hooks types
344
-
- Convert to typed input using input_of_proto
345
-
- Invoke the user's typed callback
346
-
- Convert output back to wire format using output_to_proto
347
-
348
-
This is an internal function used by {!Client} - you should not need to call
349
-
it directly. *)
226
+
Internal function used by {!Client}; you should not need to call it
227
+
directly. *)
+37
-24
lib/incoming.ml
+37
-24
lib/incoming.ml
···
10
10
11
11
(** Incoming messages from Claude CLI.
12
12
13
-
This uses the Sdk_control module's control_request_jsont and
14
-
control_response_jsont for control messages, and Message.jsont for
15
-
conversation messages. The top-level discriminator is the "type" field. *)
13
+
The top-level discriminator is the "type" field. *)
16
14
17
15
type t =
18
16
| Message of Message.t
19
-
| Control_response of Sdk_control.control_response
20
-
| Control_request of Sdk_control.control_request
17
+
| Control_response of Control.control_response
18
+
| Control_request of Control.control_request
19
+
| Rate_limit_event
21
20
22
-
let jsont : t Jsont.t =
21
+
let json : t Json.codec =
22
+
let open Json.Codec in
23
23
(* Message types use "user", "assistant", "system", "result" as type values.
24
24
Control uses "control_request" and "control_response".
25
25
26
26
We use case_mem for all types. Note: we use the inner message codecs
27
-
(User.incoming_jsont, etc.) rather than Message.jsont to avoid nesting
27
+
(User.incoming_jsont, etc.) rather than Message.json to avoid nesting
28
28
case_mem on the same "type" field. *)
29
29
let case_control_request =
30
-
Jsont.Object.Case.map "control_request" Sdk_control.control_request_jsont
30
+
Object.Case.map "control_request" Control.control_request_jsont
31
31
~dec:(fun v -> Control_request v)
32
32
in
33
33
let case_control_response =
34
-
Jsont.Object.Case.map "control_response" Sdk_control.control_response_jsont
34
+
Object.Case.map "control_response" Control.control_response_jsont
35
35
~dec:(fun v -> Control_response v)
36
36
in
37
37
let case_user =
38
-
Jsont.Object.Case.map "user" Message.User.incoming_jsont ~dec:(fun v ->
38
+
Object.Case.map "user" Message.User.incoming_jsont ~dec:(fun v ->
39
39
Message (Message.User v))
40
40
in
41
41
let case_assistant =
42
-
Jsont.Object.Case.map "assistant" Message.Assistant.incoming_jsont
43
-
~dec:(fun v -> Message (Message.Assistant v))
42
+
Object.Case.map "assistant" Message.Assistant.incoming_jsont ~dec:(fun v ->
43
+
Message (Message.Assistant v))
44
44
in
45
45
let case_system =
46
-
Jsont.Object.Case.map "system" Message.System.jsont ~dec:(fun v ->
46
+
Object.Case.map "system" Message.System.json ~dec:(fun v ->
47
47
Message (Message.System v))
48
48
in
49
49
let case_result =
50
-
Jsont.Object.Case.map "result" Message.Result.jsont ~dec:(fun v ->
50
+
Object.Case.map "result" Message.Result.json ~dec:(fun v ->
51
51
Message (Message.Result v))
52
52
in
53
+
(* rate_limit_event: CLI sends these periodically with usage info.
54
+
We decode the type field and discard the rest. *)
55
+
let rate_limit_jsont =
56
+
Object.map ~kind:"RateLimit" () |> Object.skip_unknown |> Object.seal
57
+
in
58
+
let case_rate_limit =
59
+
Object.Case.map "rate_limit_event" rate_limit_jsont ~dec:(fun () ->
60
+
Rate_limit_event)
61
+
in
53
62
let enc_case = function
54
-
| Control_request v -> Jsont.Object.Case.value case_control_request v
55
-
| Control_response v -> Jsont.Object.Case.value case_control_response v
63
+
| Control_request v -> Object.Case.value case_control_request v
64
+
| Control_response v -> Object.Case.value case_control_response v
65
+
| Rate_limit_event -> Object.Case.value case_rate_limit ()
56
66
| Message msg -> (
57
67
match msg with
58
-
| Message.User u -> Jsont.Object.Case.value case_user u
59
-
| Message.Assistant a -> Jsont.Object.Case.value case_assistant a
60
-
| Message.System s -> Jsont.Object.Case.value case_system s
61
-
| Message.Result r -> Jsont.Object.Case.value case_result r)
68
+
| Message.User u -> Object.Case.value case_user u
69
+
| Message.Assistant a -> Object.Case.value case_assistant a
70
+
| Message.System s -> Object.Case.value case_system s
71
+
| Message.Result r -> Object.Case.value case_result r)
62
72
in
63
73
let cases =
64
-
Jsont.Object.Case.
74
+
Object.Case.
65
75
[
66
76
make case_control_request;
67
77
make case_control_response;
···
69
79
make case_assistant;
70
80
make case_system;
71
81
make case_result;
82
+
make case_rate_limit;
72
83
]
73
84
in
74
-
Jsont.Object.map ~kind:"Incoming" Fun.id
75
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
85
+
Object.map ~kind:"Incoming" Fun.id
86
+
|> Object.case_member "type" string ~enc:Fun.id ~enc_case cases
76
87
~tag_to_string:Fun.id ~tag_compare:String.compare
77
-
|> Jsont.Object.finish
88
+
|> Object.seal
89
+
90
+
let pp ppf t = Json.pp_value json ppf t
+9
-5
lib/incoming.mli
+9
-5
lib/incoming.mli
···
6
6
(** Incoming messages from the Claude CLI.
7
7
8
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.
9
+
can be received from the Claude CLI, with a single json codec.
10
10
11
11
The codec uses the "type" field to discriminate between message types:
12
12
- "user", "assistant", "system", "result" -> Message variant
···
18
18
19
19
type t =
20
20
| Message of Message.t
21
-
| Control_response of Sdk_control.control_response
22
-
| Control_request of Sdk_control.control_request
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. *)
23
24
24
-
val jsont : t Jsont.t
25
+
val json : t Json.codec
25
26
(** Codec for incoming messages. Uses the "type" field to discriminate. Use
26
-
[Jsont.pp_value jsont ()] for pretty-printing. *)
27
+
[Json.pp_value json] for pretty-printing. *)
28
+
29
+
val pp : Format.formatter -> t -> unit
30
+
(** [pp ppf t] pretty-prints the incoming message. *)
+89
-57
lib/mcp_server.ml
+89
-57
lib/mcp_server.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
module J = Jsont.Json
7
-
8
6
type t = {
9
7
name : string;
10
8
version : string;
···
12
10
tool_map : (string, Tool.t) Hashtbl.t;
13
11
}
14
12
15
-
let create ~name ?(version = "1.0.0") ~tools () =
13
+
let v ~name ?(version = "1.0.0") ~tools () =
16
14
let tool_map = Hashtbl.create (List.length tools) in
17
15
List.iter (fun tool -> Hashtbl.add tool_map (Tool.name tool) tool) tools;
18
16
{ name; version; tools; tool_map }
···
21
19
let version t = t.version
22
20
let tools t = t.tools
23
21
24
-
(* JSONRPC helpers using Jsont.Json builders *)
22
+
(* JSONRPC helpers using Json.Json builders *)
25
23
26
24
let jsonrpc_success ~id result =
27
-
J.object'
25
+
Json.Value.object'
28
26
[
29
-
J.mem (J.name "jsonrpc") (J.string "2.0");
30
-
J.mem (J.name "id") id;
31
-
J.mem (J.name "result") result;
27
+
Json.Value.member (Json.Value.name "jsonrpc") (Json.Value.string "2.0");
28
+
Json.Value.member (Json.Value.name "id") id;
29
+
Json.Value.member (Json.Value.name "result") result;
32
30
]
33
31
34
32
let jsonrpc_error ~id ~code ~message =
35
-
J.object'
33
+
Json.Value.object'
36
34
[
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'
35
+
Json.Value.member (Json.Value.name "jsonrpc") (Json.Value.string "2.0");
36
+
Json.Value.member (Json.Value.name "id") id;
37
+
Json.Value.member (Json.Value.name "error")
38
+
(Json.Value.object'
41
39
[
42
-
J.mem (J.name "code") (J.number (Float.of_int code));
43
-
J.mem (J.name "message") (J.string message);
40
+
Json.Value.member (Json.Value.name "code")
41
+
(Json.Value.number (Float.of_int code));
42
+
Json.Value.member
43
+
(Json.Value.name "message")
44
+
(Json.Value.string message);
44
45
]);
45
46
]
46
47
47
48
(* Extract string from JSON *)
48
-
let get_string key (obj : Jsont.json) =
49
+
let string_of key (obj : Json.t) =
49
50
match obj with
50
-
| Jsont.Object (mems, _) -> (
51
-
match J.find_mem key mems with
52
-
| Some (_, Jsont.String (s, _)) -> Some s
51
+
| Json.Object (mems, _) -> (
52
+
match Json.Value.member_key key mems with
53
+
| Some (_, Json.String (s, _)) -> Some s
53
54
| _ -> None)
54
55
| _ -> None
55
56
56
57
(* Extract object from JSON *)
57
-
let get_object key (obj : Jsont.json) : Jsont.json option =
58
+
let object_of key (obj : Json.t) : Json.t option =
58
59
match obj with
59
-
| Jsont.Object (mems, _) -> (
60
-
match J.find_mem key mems with
61
-
| Some (_, (Jsont.Object _ as o)) -> Some o
60
+
| Json.Object (mems, _) -> (
61
+
match Json.Value.member_key key mems with
62
+
| Some (_, (Json.Object _ as o)) -> Some o
62
63
| _ -> None)
63
64
| _ -> None
64
65
65
66
(* Get ID from JSON message *)
66
-
let get_id (msg : Jsont.json) : Jsont.json =
67
+
let msg_id (msg : Json.t) : Json.t =
67
68
match msg with
68
-
| Jsont.Object (mems, _) -> (
69
-
match J.find_mem "id" mems with Some (_, id) -> id | None -> J.null ())
70
-
| _ -> J.null ()
69
+
| Json.Object (mems, _) -> (
70
+
match Json.Value.member_key "id" mems with
71
+
| Some (_, id) -> id
72
+
| None -> Json.Value.null ())
73
+
| _ -> Json.Value.null ()
71
74
72
75
(* Handle initialize request *)
73
76
let handle_initialize t ~id =
74
77
jsonrpc_success ~id
75
-
(J.object'
78
+
(Json.Value.object'
76
79
[
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'
80
+
Json.Value.member
81
+
(Json.Value.name "protocolVersion")
82
+
(Json.Value.string "2024-11-05");
83
+
Json.Value.member
84
+
(Json.Value.name "capabilities")
85
+
(Json.Value.object'
82
86
[
83
-
J.mem (J.name "name") (J.string t.name);
84
-
J.mem (J.name "version") (J.string t.version);
87
+
Json.Value.member (Json.Value.name "tools")
88
+
(Json.Value.object' []);
89
+
]);
90
+
Json.Value.member
91
+
(Json.Value.name "serverInfo")
92
+
(Json.Value.object'
93
+
[
94
+
Json.Value.member (Json.Value.name "name")
95
+
(Json.Value.string t.name);
96
+
Json.Value.member
97
+
(Json.Value.name "version")
98
+
(Json.Value.string t.version);
85
99
]);
86
100
])
87
101
···
90
104
let tools_json =
91
105
List.map
92
106
(fun tool ->
93
-
J.object'
107
+
Json.Value.object'
94
108
[
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);
109
+
Json.Value.member (Json.Value.name "name")
110
+
(Json.Value.string (Tool.name tool));
111
+
Json.Value.member
112
+
(Json.Value.name "description")
113
+
(Json.Value.string (Tool.description tool));
114
+
Json.Value.member
115
+
(Json.Value.name "inputSchema")
116
+
(Tool.input_schema tool);
98
117
])
99
118
t.tools
100
119
in
101
-
jsonrpc_success ~id (J.object' [ J.mem (J.name "tools") (J.list tools_json) ])
120
+
jsonrpc_success ~id
121
+
(Json.Value.object'
122
+
[
123
+
Json.Value.member (Json.Value.name "tools")
124
+
(Json.Value.list tools_json);
125
+
])
102
126
103
127
(* Handle tools/call request *)
104
128
let handle_tools_call t ~id ~params =
105
-
match get_string "name" params with
129
+
match string_of "name" params with
106
130
| None -> jsonrpc_error ~id ~code:(-32602) ~message:"Missing 'name' parameter"
107
131
| Some tool_name -> (
108
132
match Hashtbl.find_opt t.tool_map tool_name with
109
133
| None ->
110
134
jsonrpc_error ~id ~code:(-32601)
111
-
~message:(Printf.sprintf "Tool '%s' not found" tool_name)
135
+
~message:(Fmt.str "Tool '%s' not found" tool_name)
112
136
| Some tool -> (
113
137
let arguments =
114
-
match get_object "arguments" params with
138
+
match object_of "arguments" params with
115
139
| Some args -> args
116
-
| None -> J.object' []
140
+
| None -> Json.Value.object' []
117
141
in
118
142
let input = Tool_input.of_json arguments in
119
143
match Tool.call tool input with
120
144
| Ok content ->
121
145
jsonrpc_success ~id
122
-
(J.object' [ J.mem (J.name "content") content ])
146
+
(Json.Value.object'
147
+
[ Json.Value.member (Json.Value.name "content") content ])
123
148
| Error msg ->
124
149
(* Return error as content with is_error flag *)
125
150
jsonrpc_success ~id
126
-
(J.object'
151
+
(Json.Value.object'
127
152
[
128
-
J.mem (J.name "content")
129
-
(J.list
153
+
Json.Value.member
154
+
(Json.Value.name "content")
155
+
(Json.Value.list
130
156
[
131
-
J.object'
157
+
Json.Value.object'
132
158
[
133
-
J.mem (J.name "type") (J.string "text");
134
-
J.mem (J.name "text") (J.string msg);
159
+
Json.Value.member (Json.Value.name "type")
160
+
(Json.Value.string "text");
161
+
Json.Value.member (Json.Value.name "text")
162
+
(Json.Value.string msg);
135
163
];
136
164
]);
137
-
J.mem (J.name "isError") (J.bool true);
165
+
Json.Value.member
166
+
(Json.Value.name "isError")
167
+
(Json.Value.bool true);
138
168
])))
139
169
140
170
let handle_request t ~method_ ~params ~id =
···
144
174
| "tools/call" -> handle_tools_call t ~id ~params
145
175
| _ ->
146
176
jsonrpc_error ~id ~code:(-32601)
147
-
~message:(Printf.sprintf "Method '%s' not found" method_)
177
+
~message:(Fmt.str "Method '%s' not found" method_)
148
178
149
-
let handle_json_message t (msg : Jsont.json) =
150
-
let method_ = match get_string "method" msg with Some m -> m | None -> "" in
179
+
let handle_json_message t (msg : Json.t) =
180
+
let method_ = match string_of "method" msg with Some m -> m | None -> "" in
151
181
let params =
152
-
match get_object "params" msg with Some p -> p | None -> J.object' []
182
+
match object_of "params" msg with
183
+
| Some p -> p
184
+
| None -> Json.Value.object' []
153
185
in
154
-
let id = get_id msg in
186
+
let id = msg_id msg in
155
187
handle_request t ~method_ ~params ~id
+20
-21
lib/mcp_server.mli
+20
-21
lib/mcp_server.mli
···
12
12
{2 Basic Usage}
13
13
14
14
{[
15
-
let greet =
16
-
Tool.create ~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.get_string args "name" with
23
-
| Some name ->
24
-
Ok (Tool.text_result (Printf.sprintf "Hello, %s!" name))
25
-
| None -> Error "Missing name")
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
26
27
-
let server = Mcp_server.create ~name:"my-tools" ~tools:[ greet ] ()
27
+
let server = Mcp_server.v ~name:"my-tools" ~tools:[ greet ] ()
28
28
29
-
let options =
30
-
Options.default
31
-
|> Options.with_mcp_server ~name:"tools" server
32
-
|> Options.with_allowed_tools [ "mcp__tools__greet" ]
29
+
let options =
30
+
Options.default
31
+
|> Options.with_mcp_server ~name:"tools" server
32
+
|> Options.with_allowed_tools [ "mcp__tools__greet" ]
33
33
]}
34
34
35
35
{2 Tool Naming}
···
48
48
type t
49
49
(** Abstract type for MCP servers. *)
50
50
51
-
val create : name:string -> ?version:string -> tools:Tool.t list -> unit -> t
52
-
(** [create ~name ?version ~tools ()] creates an in-process MCP server.
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
53
54
54
@param name Server identifier. Used in tool naming: [mcp__<name>__<tool>].
55
55
@param version Server version string (default "1.0.0").
···
66
66
67
67
(** {1 MCP Protocol Handling} *)
68
68
69
-
val handle_request :
70
-
t -> method_:string -> params:Jsont.json -> id:Jsont.json -> Jsont.json
69
+
val handle_request : t -> method_:string -> params:Json.t -> id:Json.t -> Json.t
71
70
(** [handle_request t ~method_ ~params ~id] handles an MCP JSONRPC request.
72
71
73
72
Returns a JSONRPC response object with the given [id].
···
79
78
80
79
Unknown methods return a JSONRPC error response. *)
81
80
82
-
val handle_json_message : t -> Jsont.json -> Jsont.json
81
+
val handle_json_message : t -> Json.t -> Json.t
83
82
(** [handle_json_message t msg] handles a complete JSONRPC message.
84
83
85
84
Extracts method, params, and id from the message and delegates to
+327
-99
lib/message.ml
+327
-99
lib/message.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
+
open Json.Codec
7
+
6
8
let src = Logs.Src.create "claude.message" ~doc:"Claude messages"
7
9
8
10
module Log = (val Logs.src_log src : Logs.LOG)
9
11
10
12
module User = struct
11
-
type t = Proto.Message.User.t
12
-
13
-
let of_string s = Proto.Message.User.create_string s
13
+
type content = String of string | Blocks of Content_block.t list
14
+
type t = { content : content; unknown : Unknown.t }
14
15
15
-
let of_blocks blocks =
16
-
Proto.Message.User.create_blocks (List.map Content_block.to_proto blocks)
16
+
let of_string s = { content = String s; unknown = Unknown.empty }
17
+
let of_blocks blocks = { content = Blocks blocks; unknown = Unknown.empty }
17
18
18
19
let with_tool_result ~tool_use_id ~content ?is_error () =
19
-
Proto.Message.User.create_with_tool_result ~tool_use_id ~content ?is_error
20
-
()
20
+
let tool_result =
21
+
Content_block.tool_result ~tool_use_id ~content ?is_error ()
22
+
in
23
+
{ content = Blocks [ tool_result ]; unknown = Unknown.empty }
21
24
22
-
let as_text t =
23
-
match Proto.Message.User.content t with
24
-
| Proto.Message.User.String s -> Some s
25
-
| Proto.Message.User.Blocks _ -> None
25
+
let make content unknown = { content; unknown }
26
+
let content t = t.content
27
+
let unknown t = t.unknown
28
+
let as_text t = match t.content with String s -> Some s | Blocks _ -> None
26
29
27
30
let blocks t =
28
-
match Proto.Message.User.content t with
29
-
| Proto.Message.User.String s -> [ Content_block.text s ]
30
-
| Proto.Message.User.Blocks bs -> List.map Content_block.of_proto bs
31
+
match t.content with
32
+
| String s -> [ Content_block.text s ]
33
+
| Blocks bs -> bs
34
+
35
+
let decode_content json =
36
+
match json with
37
+
| Json.String (s, _) -> String s
38
+
| Json.Array (items, _) ->
39
+
let blocks =
40
+
List.map
41
+
(fun j ->
42
+
match Json.decode Content_block.json j with
43
+
| Ok v -> v
44
+
| Error e ->
45
+
invalid_arg
46
+
("Invalid content block: " ^ Json.Error.to_string e))
47
+
items
48
+
in
49
+
Blocks blocks
50
+
| _ -> failwith "Content must be string or array"
51
+
52
+
let encode_content = function
53
+
| String s -> Json.String (s, Json.Meta.none)
54
+
| Blocks blocks ->
55
+
let jsons =
56
+
List.map (fun b -> Json.encode Content_block.json b) blocks
57
+
in
58
+
Json.Array (jsons, Json.Meta.none)
59
+
60
+
let json : t Json.codec =
61
+
Object.map ~kind:"User" (fun json_content unknown ->
62
+
let content = decode_content json_content in
63
+
make content unknown)
64
+
|> Object.member "content" Value.t ~enc:(fun t ->
65
+
encode_content (content t))
66
+
|> Object.keep_unknown Unknown.mems ~enc:unknown
67
+
|> Object.seal
31
68
32
-
let of_proto proto = proto
33
-
let to_proto t = t
69
+
let incoming_jsont : t Json.codec =
70
+
let message_jsont =
71
+
Object.map ~kind:"UserMessage" (fun json_content ->
72
+
let content = decode_content json_content in
73
+
{ content; unknown = Unknown.empty })
74
+
|> Object.member "content" Value.t ~enc:(fun t ->
75
+
encode_content (content t))
76
+
|> Object.seal
77
+
in
78
+
Object.map ~kind:"UserEnvelope" Fun.id
79
+
|> Object.member "message" message_jsont ~enc:Fun.id
80
+
|> Object.seal
34
81
35
-
(* Internal wire format functions *)
36
-
let incoming_jsont = Proto.Message.User.incoming_jsont
82
+
let outgoing_jsont : t Json.codec =
83
+
let message_jsont =
84
+
Object.map ~kind:"UserOutgoingMessage" (fun _role json_content ->
85
+
let content = decode_content json_content in
86
+
{ content; unknown = Unknown.empty })
87
+
|> Object.member "role" string ~enc:(fun _ -> "user")
88
+
|> Object.member "content" Value.t ~enc:(fun t ->
89
+
encode_content (content t))
90
+
|> Object.seal
91
+
in
92
+
Object.map ~kind:"UserOutgoingEnvelope" Fun.id
93
+
|> Object.member "message" message_jsont ~enc:Fun.id
94
+
|> Object.seal
37
95
38
-
let to_json t =
39
-
match Jsont.Json.encode Proto.Message.User.jsont t with
40
-
| Ok json -> json
41
-
| Error e -> invalid_arg ("User.to_json: " ^ e)
96
+
let to_json t = Json.encode json t
42
97
end
43
98
44
99
module Assistant = struct
45
-
type error = Proto.Message.Assistant.error
46
-
type t = Proto.Message.Assistant.t
100
+
type error =
101
+
[ `Authentication_failed
102
+
| `Billing_error
103
+
| `Rate_limit
104
+
| `Invalid_request
105
+
| `Server_error
106
+
| `Unknown ]
107
+
108
+
let error_jsont : error Json.codec =
109
+
enum
110
+
[
111
+
("authentication_failed", `Authentication_failed);
112
+
("billing_error", `Billing_error);
113
+
("rate_limit", `Rate_limit);
114
+
("invalid_request", `Invalid_request);
115
+
("server_error", `Server_error);
116
+
("unknown", `Unknown);
117
+
]
118
+
119
+
type t = {
120
+
content : Content_block.t list;
121
+
model : string;
122
+
error : error option;
123
+
unknown : Unknown.t;
124
+
}
47
125
48
-
let content t =
49
-
List.map Content_block.of_proto (Proto.Message.Assistant.content t)
126
+
let create ~content ~model ?error () =
127
+
{ content; model; error; unknown = Unknown.empty }
50
128
51
-
let model t = Proto.Message.Assistant.model t
52
-
let error t = Proto.Message.Assistant.error t
129
+
let make content model error unknown = { content; model; error; unknown }
130
+
let content t = t.content
131
+
let model t = t.model
132
+
let error t = t.error
133
+
let unknown t = t.unknown
53
134
54
135
let text_blocks t =
55
136
List.filter_map
56
137
(function
57
138
| Content_block.Text text -> Some (Content_block.Text.text text)
58
139
| _ -> None)
59
-
(content t)
140
+
t.content
60
141
61
142
let tool_uses t =
62
143
List.filter_map
63
144
(function Content_block.Tool_use tool -> Some tool | _ -> None)
64
-
(content t)
145
+
t.content
65
146
66
147
let thinking_blocks t =
67
148
List.filter_map
68
149
(function Content_block.Thinking thinking -> Some thinking | _ -> None)
69
-
(content t)
150
+
t.content
70
151
71
152
let has_tool_use t =
72
153
List.exists
73
154
(function Content_block.Tool_use _ -> true | _ -> false)
74
-
(content t)
155
+
t.content
75
156
76
157
let combined_text t = String.concat "\n" (text_blocks t)
77
-
let of_proto proto = proto
78
-
let to_proto t = t
79
158
80
-
(* Internal wire format functions *)
81
-
let incoming_jsont = Proto.Message.Assistant.incoming_jsont
159
+
let json : t Json.codec =
160
+
Object.map ~kind:"Assistant" make
161
+
|> Object.member "content" (list Content_block.json) ~enc:content
162
+
|> Object.member "model" string ~enc:model
163
+
|> Object.opt_member "error" error_jsont ~enc:error
164
+
|> Object.keep_unknown Unknown.mems ~enc:unknown
165
+
|> Object.seal
82
166
83
-
let to_json t =
84
-
match Jsont.Json.encode Proto.Message.Assistant.jsont t with
85
-
| Ok json -> json
86
-
| Error e -> invalid_arg ("Assistant.to_json: " ^ e)
167
+
let incoming_jsont : t Json.codec =
168
+
Object.map ~kind:"AssistantEnvelope" Fun.id
169
+
|> Object.member "message" json ~enc:Fun.id
170
+
|> Object.seal
171
+
172
+
let to_json t = Json.encode json t
87
173
end
88
174
89
175
module System = struct
90
-
type t = Proto.Message.System.t
176
+
type init = {
177
+
session_id : string option;
178
+
model : string option;
179
+
cwd : string option;
180
+
unknown : Unknown.t;
181
+
}
182
+
183
+
type error = { error : string; unknown : Unknown.t }
184
+
type t = Init of init | Error of error
185
+
186
+
let is_init = function Init _ -> true | _ -> false
187
+
let is_error = function Error _ -> true | _ -> false
188
+
let session_id = function Init i -> i.session_id | _ -> None
189
+
let model = function Init i -> i.model | _ -> None
190
+
let cwd = function Init i -> i.cwd | _ -> None
191
+
let error_message = function Error e -> Some e.error | _ -> None
192
+
let error_msg = error_message
193
+
let unknown = function Init i -> i.unknown | Error e -> e.unknown
91
194
92
-
let is_init = function Proto.Message.System.Init _ -> true | _ -> false
93
-
let is_error = function Proto.Message.System.Error _ -> true | _ -> false
94
-
let session_id = Proto.Message.System.session_id
95
-
let model = Proto.Message.System.model
96
-
let cwd = Proto.Message.System.cwd
97
-
let error_message = Proto.Message.System.error_msg
98
-
let of_proto proto = proto
99
-
let to_proto t = t
195
+
let init ?session_id ?model ?cwd () =
196
+
Init { session_id; model; cwd; unknown = Unknown.empty }
100
197
101
-
(* Internal wire format functions *)
102
-
let jsont = Proto.Message.System.jsont
198
+
let error ~error = Error { error; unknown = Unknown.empty }
103
199
104
-
let to_json t =
105
-
match Jsont.Json.encode Proto.Message.System.jsont t with
106
-
| Ok json -> json
107
-
| Error e -> invalid_arg ("System.to_json: " ^ e)
200
+
let init_jsont : init Json.codec =
201
+
let make session_id model cwd unknown : init =
202
+
{ session_id; model; cwd; unknown }
203
+
in
204
+
Object.map ~kind:"SystemInit" make
205
+
|> Object.opt_member "session_id" string ~enc:(fun (r : init) ->
206
+
r.session_id)
207
+
|> Object.opt_member "model" string ~enc:(fun (r : init) -> r.model)
208
+
|> Object.opt_member "cwd" string ~enc:(fun (r : init) -> r.cwd)
209
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : init) -> r.unknown)
210
+
|> Object.seal
211
+
212
+
let error_jsont : error Json.codec =
213
+
let make err unknown : error = { error = err; unknown } in
214
+
Object.map ~kind:"SystemError" make
215
+
|> Object.member "error" string ~enc:(fun (r : error) -> r.error)
216
+
|> Object.keep_unknown Unknown.mems ~enc:(fun (r : error) -> r.unknown)
217
+
|> Object.seal
218
+
219
+
let json : t Json.codec =
220
+
let case_init = Object.Case.map "init" init_jsont ~dec:(fun v -> Init v) in
221
+
let case_error =
222
+
Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
223
+
in
224
+
let enc_case = function
225
+
| Init v -> Object.Case.value case_init v
226
+
| Error v -> Object.Case.value case_error v
227
+
in
228
+
let cases = Object.Case.[ make case_init; make case_error ] in
229
+
Object.map ~kind:"System" Fun.id
230
+
|> Object.case_member "subtype" string ~enc:Fun.id ~enc_case cases
231
+
~tag_to_string:Fun.id ~tag_compare:String.compare
232
+
|> Object.seal
233
+
234
+
let to_json t = Json.encode json t
108
235
end
109
236
110
237
module Result = struct
111
238
module Usage = struct
112
-
type t = Proto.Message.Result.Usage.t
239
+
type t = {
240
+
input_tokens : int option;
241
+
output_tokens : int option;
242
+
total_tokens : int option;
243
+
cache_creation_input_tokens : int option;
244
+
cache_read_input_tokens : int option;
245
+
unknown : Unknown.t;
246
+
}
113
247
114
-
let input_tokens = Proto.Message.Result.Usage.input_tokens
115
-
let output_tokens = Proto.Message.Result.Usage.output_tokens
116
-
let total_tokens = Proto.Message.Result.Usage.total_tokens
248
+
let make input_tokens output_tokens total_tokens cache_creation_input_tokens
249
+
cache_read_input_tokens unknown =
250
+
{
251
+
input_tokens;
252
+
output_tokens;
253
+
total_tokens;
254
+
cache_creation_input_tokens;
255
+
cache_read_input_tokens;
256
+
unknown;
257
+
}
117
258
118
-
let cache_creation_input_tokens =
119
-
Proto.Message.Result.Usage.cache_creation_input_tokens
259
+
let create ?input_tokens ?output_tokens ?total_tokens
260
+
?cache_creation_input_tokens ?cache_read_input_tokens () =
261
+
{
262
+
input_tokens;
263
+
output_tokens;
264
+
total_tokens;
265
+
cache_creation_input_tokens;
266
+
cache_read_input_tokens;
267
+
unknown = Unknown.empty;
268
+
}
120
269
121
-
let cache_read_input_tokens =
122
-
Proto.Message.Result.Usage.cache_read_input_tokens
270
+
let input_tokens t = t.input_tokens
271
+
let output_tokens t = t.output_tokens
272
+
let total_tokens t = t.total_tokens
273
+
let cache_creation_input_tokens t = t.cache_creation_input_tokens
274
+
let cache_read_input_tokens t = t.cache_read_input_tokens
275
+
let unknown t = t.unknown
123
276
124
-
let of_proto proto = proto
277
+
let json : t Json.codec =
278
+
Object.map ~kind:"Usage" make
279
+
|> Object.opt_member "input_tokens" int ~enc:input_tokens
280
+
|> Object.opt_member "output_tokens" int ~enc:output_tokens
281
+
|> Object.opt_member "total_tokens" int ~enc:total_tokens
282
+
|> Object.opt_member "cache_creation_input_tokens" int
283
+
~enc:cache_creation_input_tokens
284
+
|> Object.opt_member "cache_read_input_tokens" int
285
+
~enc:cache_read_input_tokens
286
+
|> Object.keep_unknown Unknown.mems ~enc:unknown
287
+
|> Object.seal
125
288
end
126
289
127
-
type t = Proto.Message.Result.t
290
+
type t = {
291
+
subtype : string;
292
+
duration_ms : int;
293
+
duration_api_ms : int;
294
+
is_error : bool;
295
+
num_turns : int;
296
+
session_id : string;
297
+
total_cost_usd : float option;
298
+
usage : Usage.t option;
299
+
result : string option;
300
+
structured_output : Json.t option;
301
+
unknown : Unknown.t;
302
+
}
303
+
304
+
let create ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
305
+
~session_id ?total_cost_usd ?usage ?result ?structured_output () =
306
+
{
307
+
subtype;
308
+
duration_ms;
309
+
duration_api_ms;
310
+
is_error;
311
+
num_turns;
312
+
session_id;
313
+
total_cost_usd;
314
+
usage;
315
+
result;
316
+
structured_output;
317
+
unknown = Unknown.empty;
318
+
}
128
319
129
-
let duration_ms = Proto.Message.Result.duration_ms
130
-
let duration_api_ms = Proto.Message.Result.duration_api_ms
131
-
let is_error = Proto.Message.Result.is_error
132
-
let num_turns = Proto.Message.Result.num_turns
133
-
let session_id = Proto.Message.Result.session_id
134
-
let total_cost_usd = Proto.Message.Result.total_cost_usd
135
-
let usage t = Option.map Usage.of_proto (Proto.Message.Result.usage t)
136
-
let result_text = Proto.Message.Result.result
137
-
let structured_output = Proto.Message.Result.structured_output
138
-
let of_proto proto = proto
139
-
let to_proto t = t
320
+
let make subtype duration_ms duration_api_ms is_error num_turns session_id
321
+
total_cost_usd usage result structured_output unknown =
322
+
{
323
+
subtype;
324
+
duration_ms;
325
+
duration_api_ms;
326
+
is_error;
327
+
num_turns;
328
+
session_id;
329
+
total_cost_usd;
330
+
usage;
331
+
result;
332
+
structured_output;
333
+
unknown;
334
+
}
140
335
141
-
(* Internal wire format functions *)
142
-
let jsont = Proto.Message.Result.jsont
336
+
let subtype t = t.subtype
337
+
let duration_ms t = t.duration_ms
338
+
let duration_api_ms t = t.duration_api_ms
339
+
let is_error t = t.is_error
340
+
let num_turns t = t.num_turns
341
+
let session_id t = t.session_id
342
+
let total_cost_usd t = t.total_cost_usd
343
+
let usage t = t.usage
344
+
let result t = t.result
345
+
let result_text = result
346
+
let structured_output t = t.structured_output
347
+
let unknown t = t.unknown
143
348
144
-
let to_json t =
145
-
match Jsont.Json.encode Proto.Message.Result.jsont t with
146
-
| Ok json -> json
147
-
| Error e -> invalid_arg ("Result.to_json: " ^ e)
349
+
let json : t Json.codec =
350
+
Object.map ~kind:"Result" make
351
+
|> Object.member "subtype" string ~enc:subtype
352
+
|> Object.member "duration_ms" int ~enc:duration_ms
353
+
|> Object.member "duration_api_ms" int ~enc:duration_api_ms
354
+
|> Object.member "is_error" bool ~enc:is_error
355
+
|> Object.member "num_turns" int ~enc:num_turns
356
+
|> Object.member "session_id" string ~enc:session_id
357
+
|> Object.opt_member "total_cost_usd" number ~enc:total_cost_usd
358
+
|> Object.opt_member "usage" Usage.json ~enc:usage
359
+
|> Object.opt_member "result" string ~enc:result
360
+
|> Object.opt_member "structured_output" Value.t ~enc:structured_output
361
+
|> Object.keep_unknown Unknown.mems ~enc:unknown
362
+
|> Object.seal
363
+
364
+
let to_json t = Json.encode json t
148
365
end
149
366
150
367
type t =
···
153
370
| System of System.t
154
371
| Result of Result.t
155
372
156
-
let of_proto = function
157
-
| Proto.Message.User u -> User (User.of_proto u)
158
-
| Proto.Message.Assistant a -> Assistant (Assistant.of_proto a)
159
-
| Proto.Message.System s -> System (System.of_proto s)
160
-
| Proto.Message.Result r -> Result (Result.of_proto r)
161
-
162
-
let to_proto = function
163
-
| User u -> Proto.Message.User (User.to_proto u)
164
-
| Assistant a -> Proto.Message.Assistant (Assistant.to_proto a)
165
-
| System s -> Proto.Message.System (System.to_proto s)
166
-
| Result r -> Proto.Message.Result (Result.to_proto r)
373
+
let json : t Json.codec =
374
+
let case_map kind obj dec = Object.Case.map kind obj ~dec in
375
+
let case_user = case_map "user" User.incoming_jsont (fun v -> User v) in
376
+
let case_assistant =
377
+
case_map "assistant" Assistant.incoming_jsont (fun v -> Assistant v)
378
+
in
379
+
let case_system = case_map "system" System.json (fun v -> System v) in
380
+
let case_result = case_map "result" Result.json (fun v -> Result v) in
381
+
let enc_case = function
382
+
| User v -> Object.Case.value case_user v
383
+
| Assistant v -> Object.Case.value case_assistant v
384
+
| System v -> Object.Case.value case_system v
385
+
| Result v -> Object.Case.value case_result v
386
+
in
387
+
let cases =
388
+
Object.Case.
389
+
[
390
+
make case_user; make case_assistant; make case_system; make case_result;
391
+
]
392
+
in
393
+
Object.map ~kind:"Message" Fun.id
394
+
|> Object.case_member "type" string ~enc:Fun.id ~enc_case cases
395
+
~tag_to_string:Fun.id ~tag_compare:String.compare
396
+
|> Object.seal
167
397
168
398
let is_user = function User _ -> true | _ -> false
169
399
let is_assistant = function Assistant _ -> true | _ -> false
···
186
416
| Assistant a -> Assistant.tool_uses a
187
417
| _ -> []
188
418
189
-
let get_session_id = function
419
+
let session_id = function
190
420
| System s -> System.session_id s
191
421
| Result r -> Some (Result.session_id r)
192
422
| _ -> None
193
423
194
-
(* Wire format conversion *)
195
424
let to_json = function
196
425
| User u -> User.to_json u
197
426
| Assistant a -> Assistant.to_json a
198
427
| System s -> System.to_json s
199
428
| Result r -> Result.to_json r
200
429
201
-
(* Convenience constructors *)
202
430
let user_string s = User (User.of_string s)
203
431
let user_blocks blocks = User (User.of_blocks blocks)
204
-
let pp fmt t = Jsont.pp_value Proto.Message.jsont () fmt (to_proto t)
205
-
let log_received t = Log.info (fun m -> m "← %a" pp t)
206
-
let log_sending t = Log.info (fun m -> m "→ %a" pp t)
432
+
let pp ppf t = Json.pp_value json ppf t
433
+
let log_received t = Log.info (fun m -> m "<- %a" pp t)
434
+
let log_sending t = Log.info (fun m -> m "-> %a" pp t)
+72
-179
lib/message.mli
+72
-179
lib/message.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Messages exchanged with Claude. Opaque types.
7
-
8
-
This module provides opaque message types that wrap the proto types but hide
9
-
the unknown fields and wire format details from the public API. *)
6
+
(** Messages exchanged with Claude. *)
10
7
11
8
val src : Logs.Src.t
12
-
(** The log source for message operations *)
9
+
(** The log source for message operations. *)
13
10
14
11
(** {1 User Messages} *)
15
12
16
13
module User : sig
17
-
(** Messages sent by the user. *)
18
-
14
+
type content = String of string | Blocks of Content_block.t list
19
15
type t
20
-
(** The type of user messages (opaque). *)
21
16
22
17
val of_string : string -> t
23
18
(** [of_string s] creates a user message with simple text content. *)
···
26
21
(** [of_blocks blocks] creates a user message with content blocks. *)
27
22
28
23
val with_tool_result :
29
-
tool_use_id:string -> content:Jsont.json -> ?is_error:bool -> unit -> t
24
+
tool_use_id:string -> content:Json.t -> ?is_error:bool -> unit -> t
30
25
(** [with_tool_result ~tool_use_id ~content ?is_error ()] creates a user
31
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
32
30
33
31
val as_text : t -> string option
34
32
(** [as_text t] returns the text content if the message is a simple string,
···
38
36
(** [blocks t] returns the content blocks, or a single text block if it's a
39
37
string message. *)
40
38
41
-
(** {1 Internal - for lib use only} *)
42
-
43
-
val of_proto : Proto.Message.User.t -> t
44
-
(** [of_proto proto] wraps a proto user message. *)
45
-
46
-
val to_proto : t -> Proto.Message.User.t
47
-
(** [to_proto t] extracts the proto user message. *)
48
-
49
-
val incoming_jsont : t Jsont.t
50
-
(** Internal codec for parsing incoming messages. *)
51
-
52
-
val to_json : t -> Jsont.json
53
-
(** Internal conversion to JSON for wire format. *)
39
+
val json : t Json.codec
40
+
val incoming_jsont : t Json.codec
41
+
val outgoing_jsont : t Json.codec
42
+
val to_json : t -> Json.t
54
43
end
55
44
56
45
(** {1 Assistant Messages} *)
57
46
58
47
module Assistant : sig
59
-
(** Messages from Claude assistant. *)
60
-
61
48
type error =
62
-
[ `Authentication_failed (** Authentication with Claude API failed *)
63
-
| `Billing_error (** Billing or account issue *)
64
-
| `Rate_limit (** Rate limit exceeded *)
65
-
| `Invalid_request (** Request was invalid *)
66
-
| `Server_error (** Internal server error *)
67
-
| `Unknown (** Unknown error type *) ]
68
-
(** The type of assistant message errors based on Python SDK error types. *)
49
+
[ `Authentication_failed
50
+
| `Billing_error
51
+
| `Rate_limit
52
+
| `Invalid_request
53
+
| `Server_error
54
+
| `Unknown ]
69
55
70
56
type t
71
-
(** The type of assistant messages (opaque). *)
72
57
73
-
val content : t -> Content_block.t list
74
-
(** [content t] returns the content blocks of the assistant message. *)
58
+
val create :
59
+
content:Content_block.t list -> model:string -> ?error:error -> unit -> t
75
60
61
+
val content : t -> Content_block.t list
76
62
val model : t -> string
77
-
(** [model t] returns the model identifier. *)
78
-
79
63
val error : t -> error option
80
-
(** [error t] returns the optional error that occurred during message
81
-
generation. *)
82
-
83
-
(** {2 Convenience accessors} *)
84
-
64
+
val unknown : t -> Unknown.t
85
65
val text_blocks : t -> string list
86
-
(** [text_blocks t] extracts all text content from the message. *)
87
-
88
66
val tool_uses : t -> Content_block.Tool_use.t list
89
-
(** [tool_uses t] extracts all tool use blocks from the message. *)
90
-
91
67
val thinking_blocks : t -> Content_block.Thinking.t list
92
-
(** [thinking_blocks t] extracts all thinking blocks from the message. *)
93
-
94
68
val combined_text : t -> string
95
-
(** [combined_text t] concatenates all text blocks into a single string. *)
96
-
97
69
val has_tool_use : t -> bool
98
-
(** [has_tool_use t] returns true if the message contains any tool use blocks.
99
-
*)
100
-
101
-
(** {1 Internal - for lib use only} *)
102
-
103
-
val of_proto : Proto.Message.Assistant.t -> t
104
-
(** [of_proto proto] wraps a proto assistant message. *)
105
-
106
-
val to_proto : t -> Proto.Message.Assistant.t
107
-
(** [to_proto t] extracts the proto assistant message. *)
108
-
109
-
val incoming_jsont : t Jsont.t
110
-
(** Internal codec for parsing incoming messages. *)
111
-
112
-
val to_json : t -> Jsont.json
113
-
(** Internal conversion to JSON for wire format. *)
70
+
val json : t Json.codec
71
+
val incoming_jsont : t Json.codec
72
+
val to_json : t -> Json.t
114
73
end
115
74
116
75
(** {1 System Messages} *)
117
76
118
77
module System : sig
119
-
(** System control and status messages. *)
78
+
type init = {
79
+
session_id : string option;
80
+
model : string option;
81
+
cwd : string option;
82
+
unknown : Unknown.t;
83
+
}
120
84
121
-
type t
122
-
(** The type of system messages (opaque). *)
85
+
type error = { error : string; unknown : Unknown.t }
86
+
type t = Init of init | Error of error
123
87
124
88
val is_init : t -> bool
125
-
(** [is_init t] returns true if the message is an init message. *)
126
-
127
89
val is_error : t -> bool
128
-
(** [is_error t] returns true if the message is an error message. *)
129
-
130
90
val session_id : t -> string option
131
-
(** [session_id t] returns session_id from Init, None otherwise. *)
132
-
133
91
val model : t -> string option
134
-
(** [model t] returns model from Init, None otherwise. *)
135
-
136
92
val cwd : t -> string option
137
-
(** [cwd t] returns cwd from Init, None otherwise. *)
138
-
139
93
val error_message : t -> string option
140
-
(** [error_message t] returns error from Error, None otherwise. *)
141
-
142
-
(** {1 Internal - for lib use only} *)
143
-
144
-
val of_proto : Proto.Message.System.t -> t
145
-
(** [of_proto proto] wraps a proto system message. *)
146
-
147
-
val to_proto : t -> Proto.Message.System.t
148
-
(** [to_proto t] extracts the proto system message. *)
149
-
150
-
val jsont : t Jsont.t
151
-
(** Internal codec for wire format. *)
152
-
153
-
val to_json : t -> Jsont.json
154
-
(** Internal conversion to JSON for wire format. *)
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 json : t Json.codec
99
+
val to_json : t -> Json.t
155
100
end
156
101
157
102
(** {1 Result Messages} *)
158
103
159
104
module Result : sig
160
-
(** Final result messages with metadata about the conversation. *)
161
-
162
105
module Usage : sig
163
-
(** Usage statistics for API calls. *)
164
-
165
106
type t
166
-
(** Type for usage statistics (opaque). *)
167
107
168
-
val input_tokens : t -> int option
169
-
(** [input_tokens t] returns the number of input tokens used. *)
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
170
116
117
+
val input_tokens : t -> int option
171
118
val output_tokens : t -> int option
172
-
(** [output_tokens t] returns the number of output tokens generated. *)
173
-
174
119
val total_tokens : t -> int option
175
-
(** [total_tokens t] returns the total number of tokens. *)
176
-
177
120
val cache_creation_input_tokens : t -> int option
178
-
(** [cache_creation_input_tokens t] returns cache creation input tokens. *)
179
-
180
121
val cache_read_input_tokens : t -> int option
181
-
(** [cache_read_input_tokens t] returns cache read input tokens. *)
182
-
183
-
(** {1 Internal - for lib use only} *)
184
-
185
-
val of_proto : Proto.Message.Result.Usage.t -> t
186
-
(** [of_proto proto] wraps a proto usage object. *)
122
+
val unknown : t -> Unknown.t
123
+
val json : t Json.codec
187
124
end
188
125
189
126
type t
190
-
(** The type of result messages (opaque). *)
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:Json.t ->
139
+
unit ->
140
+
t
191
141
142
+
val subtype : t -> string
192
143
val duration_ms : t -> int
193
-
(** [duration_ms t] returns the total duration in milliseconds. *)
194
-
195
144
val duration_api_ms : t -> int
196
-
(** [duration_api_ms t] returns the API duration in milliseconds. *)
197
-
198
145
val is_error : t -> bool
199
-
(** [is_error t] returns whether this result represents an error. *)
200
-
201
146
val num_turns : t -> int
202
-
(** [num_turns t] returns the number of conversation turns. *)
203
-
204
147
val session_id : t -> string
205
-
(** [session_id t] returns the session identifier. *)
206
-
207
148
val total_cost_usd : t -> float option
208
-
(** [total_cost_usd t] returns the optional total cost in USD. *)
209
-
210
149
val usage : t -> Usage.t option
211
-
(** [usage t] returns the optional usage statistics. *)
212
-
150
+
val result : t -> string option
213
151
val result_text : t -> string option
214
-
(** [result_text t] returns the optional result string. *)
215
-
216
-
val structured_output : t -> Jsont.json option
217
-
(** [structured_output t] returns the optional structured JSON output. *)
218
-
219
-
(** {1 Internal - for lib use only} *)
220
-
221
-
val of_proto : Proto.Message.Result.t -> t
222
-
(** [of_proto proto] wraps a proto result message. *)
223
-
224
-
val to_proto : t -> Proto.Message.Result.t
225
-
(** [to_proto t] extracts the proto result message. *)
226
-
227
-
val jsont : t Jsont.t
228
-
(** Internal codec for wire format. *)
229
-
230
-
val to_json : t -> Jsont.json
231
-
(** Internal conversion to JSON for wire format. *)
152
+
val structured_output : t -> Json.t option
153
+
val unknown : t -> Unknown.t
154
+
val json : t Json.codec
155
+
val to_json : t -> Json.t
232
156
end
233
157
234
158
(** {1 Message Union Type} *)
···
238
162
| Assistant of Assistant.t
239
163
| System of System.t
240
164
| Result of Result.t
241
-
(** The type of messages, which can be user, assistant, system, or result.
242
-
*)
243
165
244
-
val of_proto : Proto.Message.t -> t
245
-
(** [of_proto proto] converts a proto message to a lib message. *)
246
-
247
-
val to_proto : t -> Proto.Message.t
248
-
(** [to_proto t] converts a lib message to a proto message. *)
166
+
val json : t Json.codec
249
167
250
168
(** {1 Internal - wire format conversion} *)
251
169
252
-
val to_json : t -> Jsont.json
253
-
(** [to_json t] converts any message to its JSON wire format representation. *)
170
+
val to_json : t -> Json.t
254
171
255
172
(** {1 Convenience Constructors} *)
256
173
257
174
val user_string : string -> t
258
-
(** [user_string s] creates a user message with text content. *)
259
-
260
175
val user_blocks : Content_block.t list -> t
261
-
(** [user_blocks blocks] creates a user message with content blocks. *)
262
176
263
177
(** {1 Message Analysis} *)
264
178
265
179
val is_user : t -> bool
266
-
(** [is_user t] returns true if the message is from a user. *)
267
-
268
180
val is_assistant : t -> bool
269
-
(** [is_assistant t] returns true if the message is from the assistant. *)
270
-
271
181
val is_system : t -> bool
272
-
(** [is_system t] returns true if the message is a system message. *)
273
-
274
182
val is_result : t -> bool
275
-
(** [is_result t] returns true if the message is a result message. *)
276
-
277
183
val is_error : t -> bool
278
-
(** [is_error t] returns true if the message represents an error. *)
279
-
280
184
val extract_text : t -> string option
281
-
(** [extract_text t] attempts to extract text content from any message type. *)
282
-
283
185
val extract_tool_uses : t -> Content_block.Tool_use.t list
284
-
(** [extract_tool_uses t] extracts tool use blocks from assistant messages. *)
285
-
286
-
val get_session_id : t -> string option
287
-
(** [get_session_id t] extracts the session ID from system or result messages.
288
-
*)
186
+
val session_id : t -> string option
289
187
290
188
(** {1 Logging} *)
291
189
292
190
val pp : Format.formatter -> t -> unit
293
-
(** [pp fmt t] pretty-prints any message. *)
294
-
295
191
val log_received : t -> unit
296
-
(** [log_received t] logs that a message was received. *)
297
-
298
192
val log_sending : t -> unit
299
-
(** [log_sending t] logs that a message is being sent. *)
+17
-1
lib/model.ml
+17
-1
lib/model.ml
···
4
4
---------------------------------------------------------------------------*)
5
5
6
6
type t =
7
-
[ `Sonnet_4_5
7
+
[ `Sonnet_4_6
8
+
| `Sonnet_4_5
8
9
| `Sonnet_4
9
10
| `Sonnet_3_5
11
+
| `Opus_4_6
10
12
| `Opus_4_5
11
13
| `Opus_4_1
12
14
| `Opus_4
15
+
| `Haiku_4_5
13
16
| `Haiku_4
14
17
| `Custom of string ]
15
18
16
19
let to_string = function
20
+
| `Sonnet_4_6 -> "claude-sonnet-4-6"
17
21
| `Sonnet_4_5 -> "claude-sonnet-4-5"
18
22
| `Sonnet_4 -> "claude-sonnet-4"
19
23
| `Sonnet_3_5 -> "claude-sonnet-3-5"
24
+
| `Opus_4_6 -> "claude-opus-4-6"
20
25
| `Opus_4_5 -> "claude-opus-4-5"
21
26
| `Opus_4_1 -> "claude-opus-4-1"
22
27
| `Opus_4 -> "claude-opus-4"
28
+
| `Haiku_4_5 -> "claude-haiku-4-5"
23
29
| `Haiku_4 -> "claude-haiku-4"
24
30
| `Custom s -> s
25
31
32
+
let pp ppf t = Format.pp_print_string ppf (to_string t)
33
+
26
34
let of_string = function
35
+
| "claude-sonnet-4-6" | "sonnet" -> `Sonnet_4_6
27
36
| "claude-sonnet-4-5" -> `Sonnet_4_5
28
37
| "claude-sonnet-4" -> `Sonnet_4
29
38
| "claude-sonnet-3-5" -> `Sonnet_3_5
39
+
| "claude-opus-4-6" | "opus" -> `Opus_4_6
30
40
| "claude-opus-4-5" -> `Opus_4_5
31
41
| "claude-opus-4-1" -> `Opus_4_1
32
42
| "claude-opus-4" -> `Opus_4
43
+
| "claude-haiku-4-5" | "haiku" -> `Haiku_4_5
33
44
| "claude-haiku-4" -> `Haiku_4
34
45
| s -> `Custom s
46
+
47
+
let json : t Json.codec =
48
+
let enc = to_string in
49
+
let open Json.Codec in
50
+
map ~kind:"Model" ~dec:of_string ~enc string
+19
-9
lib/model.mli
+19
-9
lib/model.mli
···
10
10
escape hatch for future or unknown models. *)
11
11
12
12
type t =
13
-
[ `Sonnet_4_5 (** claude-sonnet-4-5 - Most recent Sonnet model *)
13
+
[ `Sonnet_4_6 (** claude-sonnet-4-6 - Most recent Sonnet model *)
14
+
| `Sonnet_4_5 (** claude-sonnet-4-5 - Sonnet 4.5 model *)
14
15
| `Sonnet_4 (** claude-sonnet-4 - Sonnet 4 model *)
15
16
| `Sonnet_3_5 (** claude-sonnet-3-5 - Sonnet 3.5 model *)
16
-
| `Opus_4_5 (** claude-opus-4-5 - Most recent Opus model *)
17
+
| `Opus_4_6 (** claude-opus-4-6 - Most recent Opus model *)
18
+
| `Opus_4_5 (** claude-opus-4-5 - Opus 4.5 model *)
17
19
| `Opus_4_1 (** claude-opus-4-1 - Opus 4.1 model *)
18
20
| `Opus_4 (** claude-opus-4 - Opus 4 model for complex tasks *)
19
-
| `Haiku_4 (** claude-haiku-4 - Fast, cost-effective Haiku model *)
21
+
| `Haiku_4_5 (** claude-haiku-4-5 - Most recent Haiku model *)
22
+
| `Haiku_4 (** claude-haiku-4 - Haiku 4 model *)
20
23
| `Custom of string (** Custom model string for future/unknown models *) ]
21
24
(** The type of Claude models. *)
22
25
26
+
val pp : Format.formatter -> t -> unit
27
+
(** [pp ppf t] pretty-prints the model identifier. *)
28
+
23
29
val to_string : t -> string
24
30
(** [to_string t] converts a model to its CLI string representation.
25
31
26
32
Examples:
27
-
- [`Sonnet_4_5] becomes "claude-sonnet-4-5"
28
-
- [`Opus_4_5] becomes "claude-opus-4-5"
29
-
- [`Opus_4] becomes "claude-opus-4"
30
-
- [`Custom "my-model"] becomes "my-model" *)
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". *)
31
37
32
38
val of_string : string -> t
33
39
(** [of_string s] parses a model string into a typed model.
···
36
42
become [`Custom s].
37
43
38
44
Examples:
39
-
- "claude-sonnet-4-5" becomes [`Sonnet_4_5]
40
-
- "future-model" becomes [`Custom "future-model"] *)
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 json : t Json.codec
50
+
(** [json] is the Jsont codec for model identifiers. *)
+218
-93
lib/options.ml
+218
-93
lib/options.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
let src = Logs.Src.create "claudeio.options" ~doc:"Claude configuration options"
6
+
let src = Logs.Src.create "claude.options" ~doc:"Claude configuration options"
7
7
8
8
module Log = (val Logs.src_log src : Logs.LOG)
9
9
10
+
module Wire = struct
11
+
type setting_source = User | Project | Local
12
+
13
+
let setting_source_jsont : setting_source Json.codec =
14
+
let open Json.Codec in
15
+
enum [ ("user", User); ("project", Project); ("local", Local) ]
16
+
17
+
type t = {
18
+
allowed_tools : string list;
19
+
disallowed_tools : string list;
20
+
max_thinking_tokens : int option;
21
+
system_prompt : string option;
22
+
append_system_prompt : string option;
23
+
permission_mode : Permissions.Mode.t option;
24
+
model : Model.t option;
25
+
continue_conversation : bool;
26
+
resume : string option;
27
+
max_turns : int option;
28
+
permission_prompt_tool_name : string option;
29
+
settings : string option;
30
+
add_dirs : string list;
31
+
max_budget_usd : float option;
32
+
fallback_model : Model.t option;
33
+
setting_sources : setting_source list option;
34
+
max_buffer_size : int option;
35
+
user : string option;
36
+
output_format : Structured_output.t option;
37
+
unknown : Unknown.t;
38
+
}
39
+
40
+
let empty =
41
+
{
42
+
allowed_tools = [];
43
+
disallowed_tools = [];
44
+
max_thinking_tokens = None;
45
+
system_prompt = None;
46
+
append_system_prompt = None;
47
+
permission_mode = None;
48
+
model = None;
49
+
continue_conversation = false;
50
+
resume = None;
51
+
max_turns = None;
52
+
permission_prompt_tool_name = None;
53
+
settings = None;
54
+
add_dirs = [];
55
+
max_budget_usd = None;
56
+
fallback_model = None;
57
+
setting_sources = None;
58
+
max_buffer_size = None;
59
+
user = None;
60
+
output_format = None;
61
+
unknown = Unknown.empty;
62
+
}
63
+
64
+
let allowed_tools t = t.allowed_tools
65
+
let disallowed_tools t = t.disallowed_tools
66
+
let max_thinking_tokens t = t.max_thinking_tokens
67
+
let system_prompt t = t.system_prompt
68
+
let append_system_prompt t = t.append_system_prompt
69
+
let permission_mode t = t.permission_mode
70
+
let model t = t.model
71
+
let continue_conversation t = t.continue_conversation
72
+
let resume t = t.resume
73
+
let max_turns t = t.max_turns
74
+
let permission_prompt_tool_name t = t.permission_prompt_tool_name
75
+
let settings t = t.settings
76
+
let add_dirs t = t.add_dirs
77
+
let max_budget_usd t = t.max_budget_usd
78
+
let fallback_model t = t.fallback_model
79
+
let setting_sources t = t.setting_sources
80
+
let max_buffer_size t = t.max_buffer_size
81
+
let user t = t.user
82
+
let output_format t = t.output_format
83
+
let unknown t = t.unknown
84
+
let with_allowed_tools allowed_tools t = { t with allowed_tools }
85
+
let with_disallowed_tools disallowed_tools t = { t with disallowed_tools }
86
+
87
+
let with_max_thinking_tokens max_thinking_tokens t =
88
+
{ t with max_thinking_tokens = Some max_thinking_tokens }
89
+
90
+
let with_system_prompt system_prompt t =
91
+
{ t with system_prompt = Some system_prompt }
92
+
93
+
let with_append_system_prompt append_system_prompt t =
94
+
{ t with append_system_prompt = Some append_system_prompt }
95
+
96
+
let with_permission_mode permission_mode t =
97
+
{ t with permission_mode = Some permission_mode }
98
+
99
+
let with_model model t = { t with model = Some model }
100
+
101
+
let with_continue_conversation continue_conversation t =
102
+
{ t with continue_conversation }
103
+
104
+
let with_resume resume t = { t with resume = Some resume }
105
+
let with_max_turns max_turns t = { t with max_turns = Some max_turns }
106
+
107
+
let with_permission_prompt_tool_name permission_prompt_tool_name t =
108
+
{ t with permission_prompt_tool_name = Some permission_prompt_tool_name }
109
+
110
+
let with_settings settings t = { t with settings = Some settings }
111
+
let with_add_dirs add_dirs t = { t with add_dirs }
112
+
113
+
let with_max_budget_usd max_budget_usd t =
114
+
{ t with max_budget_usd = Some max_budget_usd }
115
+
116
+
let with_fallback_model fallback_model t =
117
+
{ t with fallback_model = Some fallback_model }
118
+
119
+
let with_setting_sources setting_sources t =
120
+
{ t with setting_sources = Some setting_sources }
121
+
122
+
let with_max_buffer_size max_buffer_size t =
123
+
{ t with max_buffer_size = Some max_buffer_size }
124
+
125
+
let with_user user t = { t with user = Some user }
126
+
127
+
let with_output_format output_format t =
128
+
{ t with output_format = Some output_format }
129
+
130
+
let json : t Json.codec =
131
+
let make allowed_tools disallowed_tools max_thinking_tokens system_prompt
132
+
append_system_prompt permission_mode model continue_conversation resume
133
+
max_turns permission_prompt_tool_name settings add_dirs max_budget_usd
134
+
fallback_model setting_sources max_buffer_size user output_format
135
+
unknown =
136
+
{
137
+
allowed_tools;
138
+
disallowed_tools;
139
+
max_thinking_tokens;
140
+
system_prompt;
141
+
append_system_prompt;
142
+
permission_mode;
143
+
model;
144
+
continue_conversation;
145
+
resume;
146
+
max_turns;
147
+
permission_prompt_tool_name;
148
+
settings;
149
+
add_dirs;
150
+
max_budget_usd;
151
+
fallback_model;
152
+
setting_sources;
153
+
max_buffer_size;
154
+
user;
155
+
output_format;
156
+
unknown;
157
+
}
158
+
in
159
+
let open Json.Codec in
160
+
Object.map ~kind:"Options" make
161
+
|> Object.member "allowedTools" (list string) ~enc:allowed_tools
162
+
~dec_absent:[]
163
+
|> Object.member "disallowedTools" (list string) ~enc:disallowed_tools
164
+
~dec_absent:[]
165
+
|> Object.opt_member "maxThinkingTokens" int ~enc:max_thinking_tokens
166
+
|> Object.opt_member "systemPrompt" string ~enc:system_prompt
167
+
|> Object.opt_member "appendSystemPrompt" string ~enc:append_system_prompt
168
+
|> Object.opt_member "permissionMode" Permissions.Mode.json
169
+
~enc:permission_mode
170
+
|> Object.opt_member "model" Model.json ~enc:model
171
+
|> Object.member "continueConversation" bool ~enc:continue_conversation
172
+
~dec_absent:false
173
+
|> Object.opt_member "resume" string ~enc:resume
174
+
|> Object.opt_member "maxTurns" int ~enc:max_turns
175
+
|> Object.opt_member "permissionPromptToolName" string
176
+
~enc:permission_prompt_tool_name
177
+
|> Object.opt_member "settings" string ~enc:settings
178
+
|> Object.member "addDirs" (list string) ~enc:add_dirs ~dec_absent:[]
179
+
|> Object.opt_member "maxBudgetUsd" number ~enc:max_budget_usd
180
+
|> Object.opt_member "fallbackModel" Model.json ~enc:fallback_model
181
+
|> Object.opt_member "settingSources"
182
+
(list setting_source_jsont)
183
+
~enc:setting_sources
184
+
|> Object.opt_member "maxBufferSize" int ~enc:max_buffer_size
185
+
|> Object.opt_member "user" string ~enc:user
186
+
|> Object.opt_member "outputFormat" Structured_output.json
187
+
~enc:output_format
188
+
|> Object.keep_unknown Unknown.mems ~enc:unknown
189
+
|> Object.seal
190
+
191
+
let pp ppf t = Json.pp_value json ppf t
192
+
end
193
+
10
194
type t = {
11
195
allowed_tools : string list;
12
196
disallowed_tools : string list;
···
15
199
append_system_prompt : string option;
16
200
permission_mode : Permissions.Mode.t option;
17
201
permission_callback : Permissions.callback option;
18
-
model : Proto.Model.t option;
202
+
model : Model.t option;
19
203
cwd : Eio.Fs.dir_ty Eio.Path.t option;
20
204
env : (string * string) list;
21
205
continue_conversation : bool;
···
28
212
debug_stderr : Eio.Flow.sink_ty Eio.Flow.sink option;
29
213
hooks : Hooks.t option;
30
214
max_budget_usd : float option;
31
-
fallback_model : Proto.Model.t option;
32
-
setting_sources : Proto.Options.setting_source list option;
215
+
fallback_model : Model.t option;
216
+
setting_sources : Wire.setting_source list option;
33
217
max_buffer_size : int option;
34
218
user : string option;
35
-
output_format : Proto.Structured_output.t option;
219
+
output_format : Structured_output.t option;
36
220
mcp_servers : (string * Mcp_server.t) list;
37
221
}
38
222
···
142
326
let log_options t =
143
327
Log.debug (fun m ->
144
328
m "Options: model=%s fallback=%s max_thinking_tokens=%d max_budget=%s"
145
-
(match t.model with
146
-
| None -> "default"
147
-
| Some m -> Proto.Model.to_string m)
329
+
(match t.model with None -> "default" | Some m -> Model.to_string m)
148
330
(match t.fallback_model with
149
331
| None -> "none"
150
-
| Some m -> Proto.Model.to_string m)
332
+
| Some m -> Model.to_string m)
151
333
t.max_thinking_tokens
152
334
(match t.max_budget_usd with
153
335
| None -> "unlimited"
154
-
| Some b -> Printf.sprintf "$%.2f" b))
336
+
| Some b -> Fmt.str "$%.2f" b))
155
337
156
338
module Advanced = struct
157
-
let to_wire (t : t) : Proto.Options.t =
158
-
let base = Proto.Options.empty in
159
-
let base = Proto.Options.with_allowed_tools t.allowed_tools base in
160
-
let base = Proto.Options.with_disallowed_tools t.disallowed_tools base in
161
-
let base =
162
-
Proto.Options.with_max_thinking_tokens t.max_thinking_tokens base
163
-
in
164
-
let base =
165
-
match t.system_prompt with
166
-
| None -> base
167
-
| Some p -> Proto.Options.with_system_prompt p base
168
-
in
169
-
let base =
170
-
match t.append_system_prompt with
171
-
| None -> base
172
-
| Some p -> Proto.Options.with_append_system_prompt p base
173
-
in
174
-
let base =
175
-
match t.permission_mode with
176
-
| None -> base
177
-
| Some m ->
178
-
Proto.Options.with_permission_mode (Permissions.Mode.to_proto m) base
179
-
in
180
-
let base =
181
-
match t.model with
182
-
| None -> base
183
-
| Some m -> Proto.Options.with_model m base
184
-
in
185
-
let base =
186
-
Proto.Options.with_continue_conversation t.continue_conversation base
187
-
in
188
-
let base =
189
-
match t.resume with
190
-
| None -> base
191
-
| Some r -> Proto.Options.with_resume r base
192
-
in
193
-
let base =
194
-
match t.max_turns with
195
-
| None -> base
196
-
| Some turns -> Proto.Options.with_max_turns turns base
197
-
in
198
-
let base =
199
-
match t.permission_prompt_tool_name with
200
-
| None -> base
201
-
| Some tool -> Proto.Options.with_permission_prompt_tool_name tool base
202
-
in
203
-
let base =
204
-
match t.settings with
205
-
| None -> base
206
-
| Some s -> Proto.Options.with_settings s base
207
-
in
208
-
let base = Proto.Options.with_add_dirs t.add_dirs base in
209
-
let base =
210
-
match t.max_budget_usd with
211
-
| None -> base
212
-
| Some b -> Proto.Options.with_max_budget_usd b base
213
-
in
214
-
let base =
215
-
match t.fallback_model with
216
-
| None -> base
217
-
| Some m -> Proto.Options.with_fallback_model m base
218
-
in
219
-
let base =
220
-
match t.setting_sources with
221
-
| None -> base
222
-
| Some sources -> Proto.Options.with_setting_sources sources base
223
-
in
224
-
let base =
225
-
match t.max_buffer_size with
226
-
| None -> base
227
-
| Some size -> Proto.Options.with_max_buffer_size size base
228
-
in
229
-
let base =
230
-
match t.user with
231
-
| None -> base
232
-
| Some u -> Proto.Options.with_user u base
233
-
in
234
-
let base =
235
-
match t.output_format with
236
-
| None -> base
237
-
| Some format -> Proto.Options.with_output_format format base
238
-
in
239
-
base
339
+
let apply_opt opt f base = match opt with None -> base | Some v -> f v base
340
+
341
+
let to_wire (t : t) : Wire.t =
342
+
Wire.empty
343
+
|> Wire.with_allowed_tools t.allowed_tools
344
+
|> Wire.with_disallowed_tools t.disallowed_tools
345
+
|> Wire.with_max_thinking_tokens t.max_thinking_tokens
346
+
|> apply_opt t.system_prompt Wire.with_system_prompt
347
+
|> apply_opt t.append_system_prompt Wire.with_append_system_prompt
348
+
|> apply_opt t.permission_mode Wire.with_permission_mode
349
+
|> apply_opt t.model Wire.with_model
350
+
|> Wire.with_continue_conversation t.continue_conversation
351
+
|> apply_opt t.resume Wire.with_resume
352
+
|> apply_opt t.max_turns Wire.with_max_turns
353
+
|> apply_opt t.permission_prompt_tool_name
354
+
Wire.with_permission_prompt_tool_name
355
+
|> apply_opt t.settings Wire.with_settings
356
+
|> Wire.with_add_dirs t.add_dirs
357
+
|> apply_opt t.max_budget_usd Wire.with_max_budget_usd
358
+
|> apply_opt t.fallback_model Wire.with_fallback_model
359
+
|> apply_opt t.setting_sources Wire.with_setting_sources
360
+
|> apply_opt t.max_buffer_size Wire.with_max_buffer_size
361
+
|> apply_opt t.user Wire.with_user
362
+
|> apply_opt t.output_format Wire.with_output_format
240
363
end
364
+
365
+
let pp ppf t = Json.pp_value Wire.json ppf (Advanced.to_wire t)
+90
-30
lib/options.mli
+90
-30
lib/options.mli
···
26
26
new options value with the specified field updated:
27
27
28
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
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
34
]}
35
35
36
36
{2 Common Configuration Scenarios}
···
38
38
{3 CI/CD: Isolated, Reproducible Builds}
39
39
40
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
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
46
]}
47
47
48
48
{3 Production: Cost Control with Fallback}
49
49
50
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
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
57
]}
58
58
59
59
{3 Development: User Settings with Overrides}
60
60
61
61
{[
62
-
let dev_config =
63
-
Options.default
64
-
|> Options.with_max_budget_usd 1.0
65
-
|> Options.with_permission_mode Permissions.Mode.Default
62
+
let dev_config =
63
+
Options.default
64
+
|> Options.with_max_budget_usd 1.0
65
+
|> Options.with_permission_mode Permissions.Mode.Default
66
66
]}
67
67
68
68
{2 Advanced Options}
···
83
83
model is unavailable or overloaded. This improves reliability. *)
84
84
85
85
val src : Logs.Src.t
86
-
(** The log source for options operations *)
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 Json.codec
98
+
99
+
type t
100
+
101
+
val empty : t
102
+
val pp : Format.formatter -> t -> unit
103
+
val json : t Json.codec
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
87
144
88
145
(** {1 Types} *)
89
146
90
147
type t
91
148
(** The type of configuration options. *)
92
149
150
+
val pp : Format.formatter -> t -> unit
151
+
(** [pp ppf t] pretty-prints the options configuration. *)
152
+
93
153
val default : t
94
154
(** [default] returns the default configuration with sensible defaults:
95
155
- No tool restrictions
96
156
- 8000 max thinking tokens
97
157
- Default allow permission callback
98
-
- No custom prompts or model override *)
158
+
- No custom prompts or model override. *)
99
159
100
160
(** {1 Builder Pattern} *)
101
161
···
120
180
val with_permission_callback : Permissions.callback -> t -> t
121
181
(** [with_permission_callback callback t] sets the permission callback. *)
122
182
123
-
val with_model : Proto.Model.t -> t -> t
183
+
val with_model : Model.t -> t -> t
124
184
(** [with_model model t] sets the model override using a typed Model.t. *)
125
185
126
186
val with_cwd : [> Eio.Fs.dir_ty ] Eio.Path.t -> t -> t
···
159
219
(** [with_max_budget_usd budget t] sets the maximum spending limit in USD. The
160
220
session will terminate if this limit is exceeded. *)
161
221
162
-
val with_fallback_model : Proto.Model.t -> t -> t
222
+
val with_fallback_model : Model.t -> t -> t
163
223
(** [with_fallback_model model t] sets the fallback model using a typed Model.t.
164
224
*)
165
225
···
175
235
val with_user : string -> t -> t
176
236
(** [with_user user t] sets the Unix user for subprocess execution. *)
177
237
178
-
val with_output_format : Proto.Structured_output.t -> t -> t
238
+
val with_output_format : Structured_output.t -> t -> t
179
239
(** [with_output_format format t] sets the structured output format. *)
180
240
181
241
val with_extra_args : (string * string option) list -> t -> t
···
210
270
val permission_callback : t -> Permissions.callback option
211
271
(** [permission_callback t] returns the optional permission callback. *)
212
272
213
-
val model : t -> Proto.Model.t option
273
+
val model : t -> Model.t option
214
274
(** [model t] returns the optional model override. *)
215
275
216
276
val cwd : t -> Eio.Fs.dir_ty Eio.Path.t option
···
248
308
val max_budget_usd : t -> float option
249
309
(** [max_budget_usd t] returns the optional spending limit in USD. *)
250
310
251
-
val fallback_model : t -> Proto.Model.t option
311
+
val fallback_model : t -> Model.t option
252
312
(** [fallback_model t] returns the optional fallback model. *)
253
313
254
-
val setting_sources : t -> Proto.Options.setting_source list option
314
+
val setting_sources : t -> Wire.setting_source list option
255
315
(** [setting_sources t] returns the optional list of setting sources to load. *)
256
316
257
317
val max_buffer_size : t -> int option
···
260
320
val user : t -> string option
261
321
(** [user t] returns the optional Unix user for subprocess execution. *)
262
322
263
-
val output_format : t -> Proto.Structured_output.t option
323
+
val output_format : t -> Structured_output.t option
264
324
(** [output_format t] returns the optional structured output format. *)
265
325
266
326
val extra_args : t -> (string * string option) list
···
277
337
(** {1 Advanced: Wire Format Conversion} *)
278
338
279
339
module Advanced : sig
280
-
val to_wire : t -> Proto.Options.t
340
+
val to_wire : t -> Wire.t
281
341
(** [to_wire t] converts to wire format (excludes Eio types and callbacks).
282
342
This is used internally by the client to send options to the Claude CLI.
283
343
*)
+69
lib/outgoing.ml
+69
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 json : t Json.codec =
12
+
let open Json.Codec in
13
+
let case_control_request =
14
+
Object.Case.map "control_request" Control.control_request_jsont
15
+
~dec:(fun v -> Control_request v)
16
+
in
17
+
let case_control_response =
18
+
Object.Case.map "control_response" Control.control_response_jsont
19
+
~dec:(fun v -> Control_response v)
20
+
in
21
+
let case_user =
22
+
Object.Case.map "user" Message.User.outgoing_jsont ~dec:(fun v ->
23
+
Message (Message.User v))
24
+
in
25
+
let case_assistant =
26
+
Object.Case.map "assistant" Message.Assistant.json ~dec:(fun v ->
27
+
Message (Message.Assistant v))
28
+
in
29
+
let case_system =
30
+
Object.Case.map "system" Message.System.json ~dec:(fun v ->
31
+
Message (Message.System v))
32
+
in
33
+
let case_result =
34
+
Object.Case.map "result" Message.Result.json ~dec:(fun v ->
35
+
Message (Message.Result v))
36
+
in
37
+
let enc_case = function
38
+
| Control_request v -> Object.Case.value case_control_request v
39
+
| Control_response v -> Object.Case.value case_control_response v
40
+
| Message msg -> (
41
+
match msg with
42
+
| Message.User u -> Object.Case.value case_user u
43
+
| Message.Assistant a -> Object.Case.value case_assistant a
44
+
| Message.System s -> Object.Case.value case_system s
45
+
| Message.Result r -> Object.Case.value case_result r)
46
+
in
47
+
let cases =
48
+
Object.Case.
49
+
[
50
+
make case_control_request;
51
+
make case_control_response;
52
+
make case_user;
53
+
make case_assistant;
54
+
make case_system;
55
+
make case_result;
56
+
]
57
+
in
58
+
Object.map ~kind:"Outgoing" Fun.id
59
+
|> Object.case_member "type" string ~enc:Fun.id ~enc_case cases
60
+
~tag_to_string:Fun.id ~tag_compare:String.compare
61
+
|> Object.seal
62
+
63
+
let pp ppf t = Json.pp_value json ppf t
64
+
let to_json t = Json.encode json t
65
+
66
+
let of_json v =
67
+
match Json.decode json v with
68
+
| Ok v -> v
69
+
| Error e -> invalid_arg ("of_json: " ^ Json.Error.to_string 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 json : t Json.codec
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 -> Json.t
20
+
(** [to_json t] converts an outgoing message to JSON. *)
21
+
22
+
val of_json : Json.t -> t
23
+
(** [of_json json] parses an outgoing message from JSON.
24
+
@raise Invalid_argument if parsing fails. *)
+202
-37
lib/permissions.ml
+202
-37
lib/permissions.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
+
open Json.Codec
7
+
6
8
let src = Logs.Src.create "claude.permission" ~doc:"Claude permission system"
7
9
8
10
module Log = (val Logs.src_log src : Logs.LOG)
9
11
10
-
(** Permission modes *)
11
12
module Mode = struct
12
13
type t = Default | Accept_edits | Plan | Bypass_permissions
13
14
···
23
24
| "plan" -> Plan
24
25
| "bypassPermissions" -> Bypass_permissions
25
26
| s ->
26
-
raise
27
-
(Invalid_argument (Printf.sprintf "Mode.of_string: unknown mode %s" s))
27
+
raise (Invalid_argument (Fmt.str "Mode.of_string: unknown mode %s" s))
28
28
29
-
let of_proto : Proto.Permissions.Mode.t -> t = function
30
-
| Proto.Permissions.Mode.Default -> Default
31
-
| Proto.Permissions.Mode.Accept_edits -> Accept_edits
32
-
| Proto.Permissions.Mode.Plan -> Plan
33
-
| Proto.Permissions.Mode.Bypass_permissions -> Bypass_permissions
29
+
let json : t Json.codec =
30
+
enum
31
+
[
32
+
("default", Default);
33
+
("acceptEdits", Accept_edits);
34
+
("plan", Plan);
35
+
("bypassPermissions", Bypass_permissions);
36
+
]
37
+
end
38
+
39
+
module Behavior = struct
40
+
type t = Allow | Deny | Ask
34
41
35
-
let to_proto : t -> Proto.Permissions.Mode.t = function
36
-
| Default -> Proto.Permissions.Mode.Default
37
-
| Accept_edits -> Proto.Permissions.Mode.Accept_edits
38
-
| Plan -> Proto.Permissions.Mode.Plan
39
-
| Bypass_permissions -> Proto.Permissions.Mode.Bypass_permissions
42
+
let to_string = function Allow -> "allow" | Deny -> "deny" | Ask -> "ask"
43
+
44
+
let of_string = function
45
+
| "allow" -> Allow
46
+
| "deny" -> Deny
47
+
| "ask" -> Ask
48
+
| s ->
49
+
raise
50
+
(Invalid_argument
51
+
(Fmt.str "Behavior.of_string: unknown behavior %s" s))
52
+
53
+
let json : t Json.codec =
54
+
enum [ ("allow", Allow); ("deny", Deny); ("ask", Ask) ]
40
55
end
41
56
42
-
(** Permission rules *)
43
57
module Rule = struct
44
-
type t = { tool_name : string; rule_content : string option }
58
+
type t = {
59
+
tool_name : string;
60
+
rule_content : string option;
61
+
unknown : Unknown.t;
62
+
}
45
63
46
-
let create ~tool_name ?rule_content () = { tool_name; rule_content }
64
+
let create ~tool_name ?rule_content ?(unknown = Unknown.empty) () =
65
+
{ tool_name; rule_content; unknown }
66
+
47
67
let tool_name t = t.tool_name
48
68
let rule_content t = t.rule_content
69
+
let unknown t = t.unknown
49
70
50
-
let of_proto (proto : Proto.Permissions.Rule.t) : t =
51
-
{
52
-
tool_name = Proto.Permissions.Rule.tool_name proto;
53
-
rule_content = Proto.Permissions.Rule.rule_content proto;
54
-
}
71
+
let json : t Json.codec =
72
+
let make tool_name rule_content unknown =
73
+
{ tool_name; rule_content; unknown }
74
+
in
75
+
Object.map ~kind:"Rule" make
76
+
|> Object.member "toolName" string ~enc:tool_name
77
+
|> Object.opt_member "ruleContent" string ~enc:rule_content
78
+
|> Object.keep_unknown Unknown.mems ~enc:unknown
79
+
|> Object.seal
80
+
end
81
+
82
+
module Update = struct
83
+
type destination =
84
+
| User_settings
85
+
| Project_settings
86
+
| Local_settings
87
+
| Session
88
+
89
+
let destination_jsont : destination Json.codec =
90
+
enum
91
+
[
92
+
("userSettings", User_settings);
93
+
("projectSettings", Project_settings);
94
+
("localSettings", Local_settings);
95
+
("session", Session);
96
+
]
97
+
98
+
type update_type =
99
+
| Add_rules
100
+
| Replace_rules
101
+
| Remove_rules
102
+
| Set_mode
103
+
| Add_directories
104
+
| Remove_directories
105
+
106
+
let update_type_jsont : update_type Json.codec =
107
+
enum
108
+
[
109
+
("addRules", Add_rules);
110
+
("replaceRules", Replace_rules);
111
+
("removeRules", Remove_rules);
112
+
("setMode", Set_mode);
113
+
("addDirectories", Add_directories);
114
+
("removeDirectories", Remove_directories);
115
+
]
116
+
117
+
type t = {
118
+
update_type : update_type;
119
+
rules : Rule.t list option;
120
+
behavior : Behavior.t option;
121
+
mode : Mode.t option;
122
+
directories : string list option;
123
+
destination : destination option;
124
+
unknown : Unknown.t;
125
+
}
126
+
127
+
let create ~update_type ?rules ?behavior ?mode ?directories ?destination
128
+
?(unknown = Unknown.empty) () =
129
+
{ update_type; rules; behavior; mode; directories; destination; unknown }
130
+
131
+
let update_type t = t.update_type
132
+
let rules t = t.rules
133
+
let behavior t = t.behavior
134
+
let mode t = t.mode
135
+
let directories t = t.directories
136
+
let destination t = t.destination
137
+
let unknown t = t.unknown
55
138
56
-
let to_proto (t : t) : Proto.Permissions.Rule.t =
57
-
Proto.Permissions.Rule.create ~tool_name:t.tool_name
58
-
?rule_content:t.rule_content ()
139
+
let json : t Json.codec =
140
+
let make update_type rules behavior mode directories destination unknown =
141
+
{ update_type; rules; behavior; mode; directories; destination; unknown }
142
+
in
143
+
Object.map ~kind:"Update" make
144
+
|> Object.member "type" update_type_jsont ~enc:update_type
145
+
|> Object.opt_member "rules" (list Rule.json) ~enc:rules
146
+
|> Object.opt_member "behavior" Behavior.json ~enc:behavior
147
+
|> Object.opt_member "mode" Mode.json ~enc:mode
148
+
|> Object.opt_member "directories" (list string) ~enc:directories
149
+
|> Object.opt_member "destination" destination_jsont ~enc:destination
150
+
|> Object.keep_unknown Unknown.mems ~enc:unknown
151
+
|> Object.seal
152
+
end
153
+
154
+
module Context = struct
155
+
type t = { suggestions : Update.t list; unknown : Unknown.t }
156
+
157
+
let create ?(suggestions = []) ?(unknown = Unknown.empty) () =
158
+
{ suggestions; unknown }
159
+
160
+
let suggestions t = t.suggestions
161
+
let unknown t = t.unknown
162
+
163
+
let json : t Json.codec =
164
+
let make suggestions unknown = { suggestions; unknown } in
165
+
Object.map ~kind:"Context" make
166
+
|> Object.member "suggestions" (list Update.json) ~enc:suggestions
167
+
~dec_absent:[]
168
+
|> Object.keep_unknown Unknown.mems ~enc:unknown
169
+
|> Object.seal
170
+
end
171
+
172
+
module Result = struct
173
+
type t =
174
+
| Allow of {
175
+
updated_input : Json.t option;
176
+
updated_permissions : Update.t list option;
177
+
unknown : Unknown.t;
178
+
}
179
+
| Deny of { message : string; interrupt : bool; unknown : Unknown.t }
180
+
181
+
let allow ?updated_input ?updated_permissions ?(unknown = Unknown.empty) () =
182
+
Allow { updated_input; updated_permissions; unknown }
183
+
184
+
let deny ~message ~interrupt ?(unknown = Unknown.empty) () =
185
+
Deny { message; interrupt; unknown }
186
+
187
+
let json : t Json.codec =
188
+
let allow_record =
189
+
let make updated_input updated_permissions unknown =
190
+
Allow { updated_input; updated_permissions; unknown }
191
+
in
192
+
Object.map ~kind:"AllowRecord" make
193
+
|> Object.member "updatedInput" (option Value.t)
194
+
~enc:(function
195
+
| Allow { updated_input; _ } -> updated_input | _ -> None)
196
+
~dec_absent:None
197
+
|> Object.opt_member "updatedPermissions" (list Update.json)
198
+
~enc:(function
199
+
| Allow { updated_permissions; _ } -> updated_permissions
200
+
| _ -> None)
201
+
|> Object.keep_unknown Unknown.mems ~enc:(function
202
+
| Allow { unknown; _ } -> unknown
203
+
| _ -> Unknown.empty)
204
+
|> Object.seal
205
+
in
206
+
let deny_record =
207
+
let make message interrupt unknown =
208
+
Deny { message; interrupt; unknown }
209
+
in
210
+
Object.map ~kind:"DenyRecord" make
211
+
|> Object.member "message" string ~enc:(function
212
+
| Deny { message; _ } -> message
213
+
| _ -> "")
214
+
|> Object.member "interrupt" bool ~enc:(function
215
+
| Deny { interrupt; _ } -> interrupt
216
+
| _ -> false)
217
+
|> Object.keep_unknown Unknown.mems ~enc:(function
218
+
| Deny { unknown; _ } -> unknown
219
+
| _ -> Unknown.empty)
220
+
|> Object.seal
221
+
in
222
+
let case_allow = Object.Case.map "allow" allow_record ~dec:(fun v -> v) in
223
+
let case_deny = Object.Case.map "deny" deny_record ~dec:(fun v -> v) in
224
+
let enc_case = function
225
+
| Allow _ as v -> Object.Case.value case_allow v
226
+
| Deny _ as v -> Object.Case.value case_deny v
227
+
in
228
+
let cases = Object.Case.[ make case_allow; make case_deny ] in
229
+
Object.map ~kind:"Result" Fun.id
230
+
|> Object.case_member "behavior" string ~enc:Fun.id ~enc_case cases
231
+
~tag_to_string:Fun.id ~tag_compare:String.compare
232
+
|> Object.seal
59
233
end
60
234
61
-
(** Permission decisions *)
62
235
module Decision = struct
63
236
type t =
64
237
| Allow of { updated_input : Tool_input.t option }
···
81
254
| Allow _ -> false
82
255
| Deny { interrupt; _ } -> interrupt
83
256
84
-
let to_proto_result ~original_input (t : t) : Proto.Permissions.Result.t =
257
+
let to_proto_result ~original_input (t : t) : Result.t =
85
258
match t with
86
259
| Allow { updated_input } ->
87
260
let updated_input_json =
88
261
match updated_input with
89
262
| Some input -> Some (Tool_input.to_json input)
90
263
| None -> Some (Tool_input.to_json original_input)
91
-
(* Return original when not modified *)
92
264
in
93
-
Proto.Permissions.Result.allow ?updated_input:updated_input_json ()
94
-
| Deny { message; interrupt } ->
95
-
Proto.Permissions.Result.deny ~message ~interrupt ()
265
+
Result.allow ?updated_input:updated_input_json ()
266
+
| Deny { message; interrupt } -> Result.deny ~message ~interrupt ()
96
267
end
97
268
98
269
type context = {
···
100
271
input : Tool_input.t;
101
272
suggested_rules : Rule.t list;
102
273
}
103
-
(** Permission context *)
104
274
105
275
let extract_rules_from_proto_updates updates =
106
276
List.concat_map
107
277
(fun update ->
108
-
match Proto.Permissions.Update.rules update with
109
-
| Some rules -> List.map Rule.of_proto rules
110
-
| None -> [])
278
+
match Update.rules update with Some rules -> rules | None -> [])
111
279
updates
112
280
113
281
type callback = context -> Decision.t
114
-
(** Permission callback type *)
115
282
116
-
(** Default callbacks *)
117
283
let default_allow _ctx = Decision.allow ()
118
284
119
285
let discovery log ctx =
120
286
List.iter (fun rule -> log := rule :: !log) ctx.suggested_rules;
121
287
Decision.allow ()
122
288
123
-
(** Logging *)
124
289
let log_permission_check ~tool_name ~decision =
125
290
match decision with
126
291
| Decision.Allow _ ->
+97
-86
lib/permissions.mli
+97
-86
lib/permissions.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Permission control for tool usage.
7
-
8
-
This module provides a permission system for controlling which tools Claude
9
-
can invoke and how they can be used. It includes support for permission
10
-
modes, rules, decisions, and callbacks. *)
6
+
(** Permission control for tool usage. *)
11
7
12
8
val src : Logs.Src.t
13
-
(** The log source for permission operations. *)
14
9
15
10
(** {1 Permission Modes} *)
16
11
17
12
module Mode : sig
18
-
(** Permission modes control the overall behavior of the permission system. *)
19
-
20
-
(** The type of permission modes. *)
21
-
type t =
22
-
| Default (** Standard permission mode with normal checks *)
23
-
| Accept_edits (** Automatically accept file edits *)
24
-
| Plan (** Planning mode with restricted execution *)
25
-
| Bypass_permissions (** Bypass all permission checks *)
13
+
type t = Default | Accept_edits | Plan | Bypass_permissions
26
14
27
15
val to_string : t -> string
28
-
(** [to_string t] converts a mode to its string representation. *)
29
-
30
16
val of_string : string -> t
31
-
(** [of_string s] parses a mode from its string representation.
32
-
@raise Invalid_argument if the string is not a valid mode. *)
17
+
val json : t Json.codec
18
+
end
33
19
34
-
val of_proto : Proto.Permissions.Mode.t -> t
35
-
(** [of_proto proto] converts from the protocol representation. *)
20
+
(** {1 Behaviors} *)
36
21
37
-
val to_proto : t -> Proto.Permissions.Mode.t
38
-
(** [to_proto t] converts to the protocol representation. *)
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 json : t Json.codec
39
28
end
40
29
41
30
(** {1 Permission Rules} *)
42
31
43
32
module Rule : sig
44
-
(** Rules define specific permissions for tools. *)
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 json : t Json.codec
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 Json.codec
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 Json.codec
45
64
46
65
type t
47
-
(** The type of permission rules. *)
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 json : t Json.codec
86
+
end
87
+
88
+
(** {1 Wire-level Permission Context} *)
89
+
90
+
module Context : sig
91
+
type t
48
92
49
-
val create : tool_name:string -> ?rule_content:string -> unit -> t
50
-
(** [create ~tool_name ?rule_content ()] creates a new rule.
51
-
@param tool_name The name of the tool this rule applies to
52
-
@param rule_content Optional rule specification or pattern *)
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 json : t Json.codec
97
+
end
53
98
54
-
val tool_name : t -> string
55
-
(** [tool_name t] returns the tool name. *)
99
+
(** {1 Wire-level Permission Result} *)
56
100
57
-
val rule_content : t -> string option
58
-
(** [rule_content t] returns the optional rule content. *)
101
+
module Result : sig
102
+
type t =
103
+
| Allow of {
104
+
updated_input : Json.t option;
105
+
updated_permissions : Update.t list option;
106
+
unknown : Unknown.t;
107
+
}
108
+
| Deny of { message : string; interrupt : bool; unknown : Unknown.t }
59
109
60
-
val of_proto : Proto.Permissions.Rule.t -> t
61
-
(** [of_proto proto] converts from the protocol representation. *)
110
+
val allow :
111
+
?updated_input:Json.t ->
112
+
?updated_permissions:Update.t list ->
113
+
?unknown:Unknown.t ->
114
+
unit ->
115
+
t
62
116
63
-
val to_proto : t -> Proto.Permissions.Rule.t
64
-
(** [to_proto t] converts to the protocol representation. *)
117
+
val deny : message:string -> interrupt:bool -> ?unknown:Unknown.t -> unit -> t
118
+
val json : t Json.codec
65
119
end
66
120
67
-
(** {1 Permission Decisions} *)
121
+
(** {1 Permission Decisions (typed)} *)
68
122
69
123
module Decision : sig
70
-
(** Decisions represent the outcome of a permission check. *)
71
-
72
124
type t
73
-
(** The type of permission decisions. *)
74
125
75
126
val allow : ?updated_input:Tool_input.t -> unit -> t
76
-
(** [allow ?updated_input ()] creates an allow decision.
77
-
@param updated_input Optional modified tool input *)
78
-
79
127
val deny : message:string -> interrupt:bool -> t
80
-
(** [deny ~message ~interrupt] creates a deny decision.
81
-
@param message The reason for denying permission
82
-
@param interrupt Whether to interrupt further execution *)
83
-
84
128
val is_allow : t -> bool
85
-
(** [is_allow t] returns true if the decision allows the operation. *)
86
-
87
129
val is_deny : t -> bool
88
-
(** [is_deny t] returns true if the decision denies the operation. *)
89
-
90
130
val updated_input : t -> Tool_input.t option
91
-
(** [updated_input t] returns the optional updated tool input if the decision
92
-
is allow. *)
93
-
94
131
val deny_message : t -> string option
95
-
(** [deny_message t] returns the denial message if the decision is deny. *)
96
-
97
132
val deny_interrupt : t -> bool
98
-
(** [deny_interrupt t] returns whether to interrupt if the decision is deny.
99
-
*)
100
-
101
-
val to_proto_result :
102
-
original_input:Tool_input.t -> t -> Proto.Permissions.Result.t
103
-
(** [to_proto_result ~original_input t] converts to the protocol result
104
-
representation. When the decision allows without modification, the
105
-
original_input is returned. *)
133
+
val to_proto_result : original_input:Tool_input.t -> t -> Result.t
106
134
end
107
135
108
-
(** {1 Permission Context} *)
136
+
(** {1 Permission Context (typed)} *)
109
137
110
138
type context = {
111
-
tool_name : string; (** Name of the tool being invoked *)
112
-
input : Tool_input.t; (** Tool input parameters *)
113
-
suggested_rules : Rule.t list; (** Suggested permission rules *)
139
+
tool_name : string;
140
+
input : Tool_input.t;
141
+
suggested_rules : Rule.t list;
114
142
}
115
-
(** The context provided to permission callbacks. *)
116
143
117
-
val extract_rules_from_proto_updates :
118
-
Proto.Permissions.Update.t list -> Rule.t list
119
-
(** [extract_rules_from_proto_updates updates] extracts rules from protocol
120
-
permission updates. Used internally to convert protocol suggestions into
121
-
context rules. *)
144
+
val extract_rules_from_proto_updates : Update.t list -> Rule.t list
122
145
123
146
(** {1 Permission Callbacks} *)
124
147
125
148
type callback = context -> Decision.t
126
-
(** The type of permission callbacks. Callbacks are invoked when Claude attempts
127
-
to use a tool, allowing custom permission logic.
128
-
129
-
The callback receives a typed context with the tool name, input, and
130
-
suggested rules, and returns a decision to allow or deny the operation. *)
131
149
132
150
val default_allow : callback
133
-
(** [default_allow] always allows tool invocations. *)
134
-
135
151
val discovery : Rule.t list ref -> callback
136
-
(** [discovery log] creates a callback that collects suggested rules into the
137
-
provided reference while allowing all operations. Useful for discovering
138
-
what permissions an operation requires. *)
139
152
140
153
(** {1 Logging} *)
141
154
142
155
val log_permission_check : tool_name:string -> decision:Decision.t -> unit
143
-
(** [log_permission_check ~tool_name ~decision] logs a permission check result.
144
-
*)
+9
lib/response.ml
+9
lib/response.ml
···
87
87
| Error of Error.t
88
88
| Complete of Complete.t
89
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
+
90
99
let of_message = function
91
100
| Message.User _ ->
92
101
(* User messages are inputs, not responses *)
+4
-1
lib/response.mli
+4
-1
lib/response.mli
···
125
125
val result_text : t -> string option
126
126
(** [result_text t] returns the optional result string. *)
127
127
128
-
val structured_output : t -> Jsont.json option
128
+
val structured_output : t -> Json.t option
129
129
(** [structured_output t] returns the optional structured JSON output. *)
130
130
131
131
val of_result : Message.Result.t -> t
···
144
144
| Init of Init.t (** Session initialization *)
145
145
| Error of Error.t (** Error event *)
146
146
| Complete of Complete.t (** Session completion *)
147
+
148
+
val pp : Format.formatter -> t -> unit
149
+
(** [pp ppf t] pretty-prints the response event. *)
147
150
148
151
(** {1 Conversion} *)
149
152
+5
-15
lib/server_info.ml
+5
-15
lib/server_info.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Server capabilities and metadata. *)
7
-
8
6
type t = {
9
7
version : string;
10
8
capabilities : string list;
···
20
18
let supports_hooks t = has_capability t "hooks"
21
19
let supports_structured_output t = has_capability t "structured-output"
22
20
23
-
let of_proto (proto : Proto.Control.Server_info.t) : t =
24
-
{
25
-
version = Proto.Control.Server_info.version proto;
26
-
capabilities = Proto.Control.Server_info.capabilities proto;
27
-
commands = Proto.Control.Server_info.commands proto;
28
-
output_styles = Proto.Control.Server_info.output_styles proto;
29
-
}
30
-
31
-
let of_sdk_control (sdk : Sdk_control.Server_info.t) : t =
21
+
let of_control (c : Control.Server_info.t) : t =
32
22
{
33
-
version = Sdk_control.Server_info.version sdk;
34
-
capabilities = Sdk_control.Server_info.capabilities sdk;
35
-
commands = Sdk_control.Server_info.commands sdk;
36
-
output_styles = Sdk_control.Server_info.output_styles sdk;
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;
37
27
}
+2
-5
lib/server_info.mli
+2
-5
lib/server_info.mli
···
41
41
42
42
(** {1 Internal} *)
43
43
44
-
val of_proto : Proto.Control.Server_info.t -> t
45
-
(** [of_proto proto] converts from the protocol representation. *)
46
-
47
-
val of_sdk_control : Sdk_control.Server_info.t -> t
48
-
(** [of_sdk_control sdk] converts from the SDK control representation. *)
44
+
val of_control : Control.Server_info.t -> t
45
+
(** [of_control c] converts from the control protocol representation. *)
+16
-17
lib/structured_output.ml
+16
-17
lib/structured_output.ml
···
7
7
8
8
module Log = (val Logs.src_log src : Logs.LOG)
9
9
10
-
type t = { json_schema : Jsont.json }
10
+
type t = { json_schema : Json.t }
11
11
12
-
let json_to_string json =
13
-
match Jsont_bytesrw.encode_string' Jsont.json json with
14
-
| Ok str -> str
15
-
| Error err -> failwith (Jsont.Error.to_string err)
12
+
let pp ppf t = Json.pp ppf t.json_schema
13
+
let json_to_string json = Json.Value.to_string json
16
14
17
15
let of_json_schema schema =
18
16
Log.debug (fun m ->
···
20
18
{ json_schema = schema }
21
19
22
20
let json_schema t = t.json_schema
21
+
let to_json_schema = json_schema
23
22
24
-
(* Codec for serializing structured output format *)
25
-
let jsont : t Jsont.t =
26
-
Jsont.Object.map ~kind:"StructuredOutput" (fun json_schema -> { json_schema })
27
-
|> Jsont.Object.mem "jsonSchema" Jsont.json ~enc:(fun t -> t.json_schema)
28
-
|> Jsont.Object.finish
23
+
let json : t Json.codec =
24
+
let open Json.Codec in
25
+
Object.map ~kind:"StructuredOutput" (fun json_schema -> { json_schema })
26
+
|> Object.member "jsonSchema" Value.t ~enc:(fun t -> t.json_schema)
27
+
|> Object.seal
29
28
30
-
let to_json t =
31
-
match Jsont.Json.encode jsont t with
32
-
| Ok json -> json
33
-
| Error msg -> failwith ("Structured_output.to_json: " ^ msg)
29
+
let to_json t = Json.encode json t
34
30
35
-
let of_json json =
36
-
match Jsont.Json.decode jsont json with
31
+
let of_json v =
32
+
match Json.decode json v with
37
33
| Ok t -> t
38
-
| Error msg -> raise (Invalid_argument ("Structured_output.of_json: " ^ msg))
34
+
| Error err ->
35
+
raise
36
+
(Invalid_argument
37
+
("Structured_output.of_json: " ^ Json.Error.to_string err))
+18
-139
lib/structured_output.mli
+18
-139
lib/structured_output.mli
···
8
8
This module provides structured output support for Claude, allowing you to
9
9
specify the expected output format using JSON schemas. When a structured
10
10
output format is configured, Claude will return its response in the
11
-
specified JSON format, validated against your schema.
12
-
13
-
{2 Overview}
14
-
15
-
Structured outputs ensure that Claude's responses conform to a specific JSON
16
-
schema, making it easier to parse and use the results programmatically. This
17
-
is particularly useful for:
18
-
19
-
- Extracting structured data from unstructured text
20
-
- Building APIs that require consistent JSON responses
21
-
- Integrating Claude into data pipelines
22
-
- Ensuring type-safe parsing of Claude's outputs
23
-
24
-
{2 Creating Output Formats}
25
-
26
-
Use {!of_json_schema} to specify a JSON Schema as a {!type:Jsont.json}
27
-
value:
28
-
{[
29
-
let meta = Jsont.Meta.none in
30
-
let schema = Jsont.Object ([
31
-
(("type", meta), Jsont.String ("object", meta));
32
-
(("properties", meta), Jsont.Object ([
33
-
(("name", meta), Jsont.Object ([
34
-
(("type", meta), Jsont.String ("string", meta))
35
-
], meta));
36
-
(("age", meta), Jsont.Object ([
37
-
(("type", meta), Jsont.String ("integer", meta))
38
-
], meta));
39
-
], meta));
40
-
(("required", meta), Jsont.Array ([
41
-
Jsont.String ("name", meta);
42
-
Jsont.String ("age", meta)
43
-
], meta));
44
-
], meta) in
45
-
46
-
let format = Structured_output.of_json_schema schema
47
-
]}
48
-
49
-
{3 Helper Functions for Building Schemas}
50
-
51
-
For complex schemas, you can use helper functions to make construction
52
-
easier:
53
-
{[
54
-
let json_object fields = Jsont.Object (fields, Jsont.Meta.none)
55
-
let json_string s = Jsont.String (s, Jsont.Meta.none)
56
-
let json_array items = Jsont.Array (items, Jsont.Meta.none)
57
-
let json_field name value = ((name, Jsont.Meta.none), value)
58
-
59
-
let person_schema =
60
-
json_object
61
-
[
62
-
json_field "type" (json_string "object");
63
-
json_field "properties"
64
-
(json_object
65
-
[
66
-
json_field "name"
67
-
(json_object [ json_field "type" (json_string "string") ]);
68
-
json_field "age"
69
-
(json_object [ json_field "type" (json_string "integer") ]);
70
-
]);
71
-
json_field "required"
72
-
(json_array [ json_string "name"; json_string "age" ]);
73
-
]
74
-
75
-
let format = Structured_output.of_json_schema person_schema
76
-
]}
77
-
78
-
{2 Usage with Claude Client}
79
-
80
-
{[
81
-
let options = Options.default
82
-
|> Options.with_output_format format
83
-
84
-
let client = Client.create ~sw ~process_mgr ~options () in
85
-
Client.query client "Extract person info from: John is 30 years old";
86
-
87
-
let messages = Client.receive_all client in
88
-
List.iter (function
89
-
| Message.Result result ->
90
-
(match Message.Result.structured_output result with
91
-
| Some json -> (* Process validated JSON *)
92
-
let json_str = match Jsont_bytesrw.encode_string' Jsont.json json with
93
-
| Ok s -> s
94
-
| Error err -> Jsont.Error.to_string err
95
-
in
96
-
Printf.printf "Structured output: %s\n" json_str
97
-
| None -> ())
98
-
| _ -> ()
99
-
) messages
100
-
]}
101
-
102
-
{2 JSON Schema Support}
103
-
104
-
The module supports standard JSON Schema Draft 7, including:
105
-
- Primitive types (string, integer, number, boolean, null)
106
-
- Objects with properties and required fields
107
-
- Arrays with item schemas
108
-
- Enumerations
109
-
- Nested objects and arrays
110
-
- Complex validation rules
111
-
112
-
@see <https://json-schema.org/> JSON Schema specification
113
-
@see <https://erratique.ch/software/jsont> jsont documentation *)
11
+
specified JSON format, validated against your schema. *)
114
12
115
13
val src : Logs.Src.t
116
-
(** The log source for structured output operations *)
14
+
(** The log source for structured output operations. *)
117
15
118
16
(** {1 Output Format Configuration} *)
119
17
120
18
type t
121
19
(** The type of structured output format configurations. *)
122
20
123
-
val of_json_schema : Jsont.json -> t
21
+
val pp : Format.formatter -> t -> unit
22
+
(** [pp ppf t] pretty-prints the structured output configuration. *)
23
+
24
+
val of_json_schema : Json.t -> t
124
25
(** [of_json_schema schema] creates an output format from a JSON Schema.
125
26
126
-
The schema should be a valid JSON Schema Draft 7 as a {!type:Jsont.json}
127
-
value.
128
-
129
-
Example:
130
-
{[
131
-
let meta = Jsont.Meta.none in
132
-
let schema = Jsont.Object ([
133
-
(("type", meta), Jsont.String ("object", meta));
134
-
(("properties", meta), Jsont.Object ([
135
-
(("name", meta), Jsont.Object ([
136
-
(("type", meta), Jsont.String ("string", meta))
137
-
], meta));
138
-
(("age", meta), Jsont.Object ([
139
-
(("type", meta), Jsont.String ("integer", meta))
140
-
], meta));
141
-
], meta));
142
-
(("required", meta), Jsont.Array ([
143
-
Jsont.String ("name", meta);
144
-
Jsont.String ("age", meta)
145
-
], meta));
146
-
], meta) in
27
+
The schema should be a valid JSON Schema Draft 7 as a {!type:Json.t} value.
28
+
*)
147
29
148
-
let format = Structured_output.of_json_schema schema
149
-
]} *)
30
+
val json_schema : t -> Json.t
31
+
(** [json_schema t] returns the underlying JSON Schema. *)
150
32
151
-
val json_schema : t -> Jsont.json
152
-
(** [json_schema t] returns the JSON Schema. *)
33
+
val to_json_schema : t -> Json.t
34
+
(** [to_json_schema t] is an alias of {!json_schema}. *)
153
35
154
-
val jsont : t Jsont.t
36
+
val json : t Json.codec
155
37
(** Codec for structured output format. *)
156
38
157
-
(** {1 Serialization}
39
+
(** {1 Serialization} *)
158
40
159
-
Internal use for encoding/decoding with the CLI. *)
41
+
val to_json : t -> Json.t
42
+
(** [to_json t] converts the output format to its JSON representation. *)
160
43
161
-
val to_json : t -> Jsont.json
162
-
(** [to_json t] converts the output format to its JSON representation. Internal
163
-
use only. *)
164
-
165
-
val of_json : Jsont.json -> t
166
-
(** [of_json json] parses an output format from JSON. Internal use only.
44
+
val of_json : Json.t -> t
45
+
(** [of_json json] parses an output format from JSON.
167
46
@raise Invalid_argument if the JSON is not a valid output format. *)
+45
-32
lib/tool.ml
+45
-32
lib/tool.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
module J = Jsont.Json
7
-
8
6
type t = {
9
7
name : string;
10
8
description : string;
11
-
input_schema : Jsont.json;
12
-
handler : Tool_input.t -> (Jsont.json, string) result;
9
+
input_schema : Json.t;
10
+
handler : Tool_input.t -> (Json.t, string) result;
13
11
}
14
12
15
-
let create ~name ~description ~input_schema ~handler =
13
+
let v ~name ~description ~input_schema ~handler =
16
14
{ name; description; input_schema; handler }
17
15
16
+
let pp ppf t = Fmt.pf ppf "<tool:%s>" t.name
18
17
let name t = t.name
19
18
let description t = t.description
20
19
let input_schema t = t.input_schema
21
20
let call t input = t.handler input
22
21
23
-
(* Convenience constructors using Jsont.Json builders *)
24
-
25
22
let text_result s =
26
-
J.list
23
+
Json.Value.list
27
24
[
28
-
J.object'
25
+
Json.Value.object'
29
26
[
30
-
J.mem (J.name "type") (J.string "text");
31
-
J.mem (J.name "text") (J.string s);
27
+
Json.Value.member (Json.Value.name "type") (Json.Value.string "text");
28
+
Json.Value.member (Json.Value.name "text") (Json.Value.string s);
32
29
];
33
30
]
34
31
35
32
let error_result s =
36
-
J.list
33
+
Json.Value.list
37
34
[
38
-
J.object'
35
+
Json.Value.object'
39
36
[
40
-
J.mem (J.name "type") (J.string "text");
41
-
J.mem (J.name "text") (J.string s);
42
-
J.mem (J.name "is_error") (J.bool true);
37
+
Json.Value.member (Json.Value.name "type") (Json.Value.string "text");
38
+
Json.Value.member (Json.Value.name "text") (Json.Value.string s);
39
+
Json.Value.member (Json.Value.name "is_error") (Json.Value.bool true);
43
40
];
44
41
]
45
42
46
-
(* Schema helpers *)
43
+
let schema_string =
44
+
Json.Value.object'
45
+
[ Json.Value.member (Json.Value.name "type") (Json.Value.string "string") ]
46
+
47
+
let schema_int =
48
+
Json.Value.object'
49
+
[ Json.Value.member (Json.Value.name "type") (Json.Value.string "integer") ]
50
+
51
+
let schema_number =
52
+
Json.Value.object'
53
+
[ Json.Value.member (Json.Value.name "type") (Json.Value.string "number") ]
47
54
48
-
let schema_string = J.object' [ J.mem (J.name "type") (J.string "string") ]
49
-
let schema_int = J.object' [ J.mem (J.name "type") (J.string "integer") ]
50
-
let schema_number = J.object' [ J.mem (J.name "type") (J.string "number") ]
51
-
let schema_bool = J.object' [ J.mem (J.name "type") (J.string "boolean") ]
55
+
let schema_bool =
56
+
Json.Value.object'
57
+
[ Json.Value.member (Json.Value.name "type") (Json.Value.string "boolean") ]
52
58
53
59
let schema_array item_schema =
54
-
J.object'
60
+
Json.Value.object'
55
61
[
56
-
J.mem (J.name "type") (J.string "array");
57
-
J.mem (J.name "items") item_schema;
62
+
Json.Value.member (Json.Value.name "type") (Json.Value.string "array");
63
+
Json.Value.member (Json.Value.name "items") item_schema;
58
64
]
59
65
60
66
let schema_string_enum values =
61
-
J.object'
67
+
Json.Value.object'
62
68
[
63
-
J.mem (J.name "type") (J.string "string");
64
-
J.mem (J.name "enum") (J.list (List.map J.string values));
69
+
Json.Value.member (Json.Value.name "type") (Json.Value.string "string");
70
+
Json.Value.member (Json.Value.name "enum")
71
+
(Json.Value.list (List.map Json.Value.string values));
65
72
]
66
73
67
74
let schema_object props ~required =
68
-
J.object'
75
+
Json.Value.object'
69
76
[
70
-
J.mem (J.name "type") (J.string "object");
71
-
J.mem (J.name "properties")
72
-
(J.object' (List.map (fun (k, v) -> J.mem (J.name k) v) props));
73
-
J.mem (J.name "required") (J.list (List.map J.string required));
77
+
Json.Value.member (Json.Value.name "type") (Json.Value.string "object");
78
+
Json.Value.member
79
+
(Json.Value.name "properties")
80
+
(Json.Value.object'
81
+
(List.map
82
+
(fun (k, v) -> Json.Value.member (Json.Value.name k) v)
83
+
props));
84
+
Json.Value.member
85
+
(Json.Value.name "required")
86
+
(Json.Value.list (List.map Json.Value.string required));
74
87
]
+49
-48
lib/tool.mli
+49
-48
lib/tool.mli
···
11
11
{2 Basic Usage}
12
12
13
13
{[
14
-
let greet =
15
-
Tool.create ~name:"greet" ~description:"Greet a user by name"
16
-
~input_schema:
17
-
(`O
18
-
[
19
-
("type", `String "object");
20
-
( "properties",
21
-
`O [ ("name", `O [ ("type", `String "string") ]) ] );
22
-
("required", `A [ `String "name" ]);
23
-
])
24
-
~handler:(fun args ->
25
-
match Tool_input.get_string args "name" with
26
-
| Some name ->
27
-
Ok
28
-
(`A
29
-
[
30
-
`O
31
-
[
32
-
("type", `String "text");
33
-
("text", `String (Printf.sprintf "Hello, %s!" name));
34
-
];
35
-
])
36
-
| None -> Error "Missing 'name' parameter")
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")
37
36
]}
38
37
39
38
{2 Tool Response Format}
···
44
43
45
44
Content blocks are typically:
46
45
{[
47
-
`A [ `O [ ("type", `String "text"); ("text", `String "result") ] ]
46
+
`A [ `O [ ("type", `String "text"); ("text", `String "result") ] ]
48
47
]} *)
49
48
50
49
type t
51
50
(** Abstract type for tool definitions. *)
52
51
53
-
val create :
52
+
val pp : Format.formatter -> t -> unit
53
+
(** [pp ppf t] pretty-prints the tool definition. *)
54
+
55
+
val v :
54
56
name:string ->
55
57
description:string ->
56
-
input_schema:Jsont.json ->
57
-
handler:(Tool_input.t -> (Jsont.json, string) result) ->
58
+
input_schema:Json.t ->
59
+
handler:(Tool_input.t -> (Json.t, string) result) ->
58
60
t
59
-
(** [create ~name ~description ~input_schema ~handler] creates a custom tool.
61
+
(** [v ~name ~description ~input_schema ~handler] creates a custom tool.
60
62
61
63
@param name
62
64
Unique tool identifier. Claude uses this in function calls. When
···
77
79
val description : t -> string
78
80
(** [description t] returns the tool's description. *)
79
81
80
-
val input_schema : t -> Jsont.json
82
+
val input_schema : t -> Json.t
81
83
(** [input_schema t] returns the JSON Schema for inputs. *)
82
84
83
-
val call : t -> Tool_input.t -> (Jsont.json, string) result
85
+
val call : t -> Tool_input.t -> (Json.t, string) result
84
86
(** [call t input] invokes the tool handler with the given input. *)
85
87
86
88
(** {1 Convenience Constructors}
87
89
88
90
Helper functions for common tool patterns. *)
89
91
90
-
val text_result : string -> Jsont.json
92
+
val text_result : string -> Json.t
91
93
(** [text_result s] creates a text content result:
92
-
[\`A [\`O ["type", \`String "text"; "text", \`String s]]] *)
94
+
[\`A [\`O ["type", \`String "text"; "text", \`String s]]]. *)
93
95
94
-
val error_result : string -> Jsont.json
96
+
val error_result : string -> Json.t
95
97
(** [error_result s] creates an error content result with is_error flag. *)
96
98
97
99
(** {2 Schema Helpers}
98
100
99
101
Build JSON Schema objects more easily. *)
100
102
101
-
val schema_object :
102
-
(string * Jsont.json) list -> required:string list -> Jsont.json
103
+
val schema_object : (string * Json.t) list -> required:string list -> Json.t
103
104
(** [schema_object props ~required] creates an object schema.
104
105
{[
105
-
schema_object
106
-
[ ("name", schema_string); ("age", schema_int) ]
107
-
~required:[ "name" ]
106
+
schema_object
107
+
[ ("name", schema_string); ("age", schema_int) ]
108
+
~required:[ "name" ]
108
109
]} *)
109
110
110
-
val schema_string : Jsont.json
111
-
(** String type schema: [{"type": "string"}] *)
111
+
val schema_string : Json.t
112
+
(** [schema_string] is string type schema: [{"type": "string"}]. *)
112
113
113
-
val schema_int : Jsont.json
114
-
(** Integer type schema: [{"type": "integer"}] *)
114
+
val schema_int : Json.t
115
+
(** [schema_int] is integer type schema: [{"type": "integer"}]. *)
115
116
116
-
val schema_number : Jsont.json
117
-
(** Number type schema: [{"type": "number"}] *)
117
+
val schema_number : Json.t
118
+
(** [schema_number] is number type schema: [{"type": "number"}]. *)
118
119
119
-
val schema_bool : Jsont.json
120
-
(** Boolean type schema: [{"type": "boolean"}] *)
120
+
val schema_bool : Json.t
121
+
(** [schema_bool] is boolean type schema: [{"type": "boolean"}]. *)
121
122
122
-
val schema_array : Jsont.json -> Jsont.json
123
+
val schema_array : Json.t -> Json.t
123
124
(** [schema_array item_schema] creates array schema with given item type. *)
124
125
125
-
val schema_string_enum : string list -> Jsont.json
126
+
val schema_string_enum : string list -> Json.t
126
127
(** [schema_string_enum values] creates enum schema for string values. *)
+43
-68
lib/tool_input.ml
+43
-68
lib/tool_input.ml
···
5
5
6
6
(** Opaque tool input with typed accessors. *)
7
7
8
-
type t = Jsont.json
8
+
type t = Json.t
9
+
10
+
let pp = Json.pp
9
11
10
12
(** {1 Escape Hatch} *)
11
13
···
15
17
(** {1 Helper Functions} *)
16
18
17
19
(* Extract members from JSON object, or return empty list if not an object *)
18
-
let get_members = function Jsont.Object (members, _) -> members | _ -> []
20
+
let members = function Json.Object (members, _) -> members | _ -> []
19
21
20
22
(* Find a member by key in the object *)
21
-
let find_member key members =
23
+
let member key mems =
22
24
List.find_map
23
25
(fun ((name, _), value) -> if name = key then Some value else None)
24
-
members
26
+
mems
25
27
26
28
(** {1 Typed Accessors} *)
27
29
28
-
let get_string t key =
29
-
let members = get_members t in
30
-
match find_member key members with
30
+
let string t key =
31
+
let mems = members t in
32
+
match member key mems with
31
33
| Some json -> (
32
-
match Jsont.Json.decode Jsont.string json with
34
+
match Json.decode Json.Codec.string json with
33
35
| Ok s -> Some s
34
36
| Error _ -> None)
35
37
| None -> None
36
38
37
-
let get_int t key =
38
-
let members = get_members t in
39
-
match find_member key members with
39
+
let int t key =
40
+
let mems = members t in
41
+
match member key mems with
40
42
| Some json -> (
41
-
match Jsont.Json.decode Jsont.int json with
43
+
match Json.decode Json.Codec.int json with
42
44
| Ok i -> Some i
43
45
| Error _ -> None)
44
46
| None -> None
45
47
46
-
let get_bool t key =
47
-
let members = get_members t in
48
-
match find_member key members with
48
+
let bool t key =
49
+
let mems = members t in
50
+
match member key mems with
49
51
| Some json -> (
50
-
match Jsont.Json.decode Jsont.bool json with
52
+
match Json.decode Json.Codec.bool json with
51
53
| Ok b -> Some b
52
54
| Error _ -> None)
53
55
| None -> None
54
56
55
-
let get_float t key =
56
-
let members = get_members t in
57
-
match find_member key members with
57
+
let float t key =
58
+
let mems = members t in
59
+
match member key mems with
58
60
| Some json -> (
59
-
match Jsont.Json.decode Jsont.number json with
61
+
match Json.decode Json.Codec.number json with
60
62
| Ok f -> Some f
61
63
| Error _ -> None)
62
64
| None -> None
63
65
64
-
let get_string_list t key =
65
-
let members = get_members t in
66
-
match find_member key members with
66
+
let string_list t key =
67
+
let mems = members t in
68
+
match member key mems with
67
69
| Some json -> (
68
70
match json with
69
-
| Jsont.Array (items, _) ->
71
+
| Json.Array (items, _) ->
70
72
let strings =
71
73
List.filter_map
72
74
(fun item ->
73
-
match Jsont.Json.decode Jsont.string item with
75
+
match Json.decode Json.Codec.string item with
74
76
| Ok s -> Some s
75
77
| Error _ -> None)
76
78
items
77
79
in
78
-
(* Only return Some if all items were strings *)
79
80
if List.length strings = List.length items then Some strings else None
80
81
| _ -> None)
81
82
| None -> None
82
83
83
84
let keys t =
84
-
let members = get_members t in
85
-
List.map (fun ((name, _), _) -> name) members
85
+
let mems = members t in
86
+
List.map (fun ((name, _), _) -> name) mems
86
87
87
88
let is_empty t =
88
89
match t with
89
-
| Jsont.Object ([], _) -> true
90
-
| Jsont.Object _ -> false
90
+
| Json.Object ([], _) -> true
91
+
| Json.Object _ -> false
91
92
| _ -> true
92
93
93
94
(** {1 Construction} *)
94
95
95
-
let empty = Jsont.Object ([], Jsont.Meta.none)
96
+
let empty = Json.Object ([], Json.Meta.none)
96
97
97
98
let add_member key value t =
98
-
let members = get_members t in
99
-
let new_member = ((key, Jsont.Meta.none), value) in
99
+
let mems = members t in
100
+
let new_member = ((key, Json.Meta.none), value) in
100
101
(* Replace existing member or add new one *)
101
-
let filtered_members =
102
-
List.filter (fun ((name, _), _) -> name <> key) members
103
-
in
104
-
Jsont.Object (new_member :: filtered_members, Jsont.Meta.none)
102
+
let filtered_members = List.filter (fun ((name, _), _) -> name <> key) mems in
103
+
Json.Object (new_member :: filtered_members, Json.Meta.none)
105
104
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
105
+
let add_string key value t = add_member key (Json.Value.string value) t
113
106
114
107
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
108
+
add_member key (Json.Value.number (Float.of_int value)) t
121
109
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
110
+
let add_bool key value t = add_member key (Json.Value.bool value) t
111
+
let add_float key value t = add_member key (Json.Value.number value) t
137
112
138
113
let of_assoc assoc =
139
114
let members =
140
-
List.map (fun (key, json) -> ((key, Jsont.Meta.none), json)) assoc
115
+
List.map (fun (key, json) -> ((key, Json.Meta.none), json)) assoc
141
116
in
142
-
Jsont.Object (members, Jsont.Meta.none)
117
+
Json.Object (members, Json.Meta.none)
143
118
144
119
let of_string_pairs pairs =
145
120
let assoc =
146
121
List.map
147
-
(fun (key, value) -> (key, Jsont.String (value, Jsont.Meta.none)))
122
+
(fun (key, value) -> (key, Json.String (value, Json.Meta.none)))
148
123
pairs
149
124
in
150
125
of_assoc assoc
+18
-18
lib/tool_input.mli
+18
-18
lib/tool_input.mli
···
12
12
type t
13
13
(** Abstract type for tool inputs. *)
14
14
15
+
val pp : Format.formatter -> t -> unit
16
+
(** [pp ppf t] pretty-prints the tool input. *)
17
+
15
18
(** {1 Typed Accessors} *)
16
19
17
-
val get_string : t -> string -> string option
18
-
(** [get_string t key] returns the string value for [key], if present and a
19
-
string. *)
20
-
21
-
val get_int : t -> string -> int option
22
-
(** [get_int t key] returns the integer value for [key], if present and an int.
20
+
val string : t -> string -> string option
21
+
(** [string t key] returns the string value for [key], if present and a string.
23
22
*)
24
23
25
-
val get_bool : t -> string -> bool option
26
-
(** [get_bool t key] returns the boolean value for [key], if present and a bool.
27
-
*)
24
+
val int : t -> string -> int option
25
+
(** [int t key] returns the integer value for [key], if present and an int. *)
28
26
29
-
val get_float : t -> string -> float option
30
-
(** [get_float t key] returns the float value for [key], if present and a float.
31
-
*)
27
+
val bool : t -> string -> bool option
28
+
(** [bool t key] returns the boolean value for [key], if present and a bool. *)
32
29
33
-
val get_string_list : t -> string -> string list option
34
-
(** [get_string_list t key] returns the string list for [key], if present and a
35
-
list of strings. *)
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
36
37
37
val keys : t -> string list
38
38
(** [keys t] returns all keys in the input. *)
···
42
42
43
43
(** {1 Escape Hatch} *)
44
44
45
-
val to_json : t -> Jsont.json
45
+
val to_json : t -> Json.t
46
46
(** [to_json t] returns the underlying JSON for advanced use cases. *)
47
47
48
-
val of_json : Jsont.json -> t
48
+
val of_json : Json.t -> t
49
49
(** [of_json json] wraps JSON as a tool input. *)
50
50
51
51
(** {1 Construction} *)
···
65
65
val add_float : string -> float -> t -> t
66
66
(** [add_float key value t] adds a float field. *)
67
67
68
-
val of_assoc : (string * Jsont.json) list -> t
68
+
val of_assoc : (string * Json.t) list -> t
69
69
(** [of_assoc assoc] creates tool input from an association list. *)
70
70
71
71
val of_string_pairs : (string * string) list -> t
+81
-130
lib/transport.ml
+81
-130
lib/transport.ml
···
23
23
}
24
24
25
25
let setting_source_to_string = function
26
-
| Proto.Options.User -> "user"
27
-
| Proto.Options.Project -> "project"
28
-
| Proto.Options.Local -> "local"
29
-
30
-
let build_command ~claude_path ~options =
31
-
let cmd = [ claude_path; "--output-format"; "stream-json"; "--verbose" ] in
32
-
33
-
let cmd =
34
-
match Options.system_prompt options with
35
-
| Some prompt -> cmd @ [ "--system-prompt"; prompt ]
36
-
| None -> cmd
37
-
in
38
-
39
-
let cmd =
40
-
match Options.append_system_prompt options with
41
-
| Some prompt -> cmd @ [ "--append-system-prompt"; prompt ]
42
-
| None -> cmd
43
-
in
44
-
45
-
let cmd =
46
-
match Options.allowed_tools options with
47
-
| [] -> cmd
48
-
| tools -> cmd @ [ "--allowedTools"; String.concat "," tools ]
49
-
in
50
-
51
-
let cmd =
52
-
match Options.disallowed_tools options with
53
-
| [] -> cmd
54
-
| tools -> cmd @ [ "--disallowedTools"; String.concat "," tools ]
55
-
in
56
-
57
-
let cmd =
58
-
match Options.model options with
59
-
| Some model -> cmd @ [ "--model"; Model.to_string model ]
60
-
| None -> cmd
61
-
in
62
-
63
-
let cmd =
64
-
match Options.permission_mode options with
65
-
| Some mode ->
66
-
let mode_str = Permissions.Mode.to_string mode in
67
-
cmd @ [ "--permission-mode"; mode_str ]
68
-
| None -> cmd
69
-
in
70
-
71
-
let cmd =
72
-
match Options.permission_prompt_tool_name options with
73
-
| Some tool_name -> cmd @ [ "--permission-prompt-tool"; tool_name ]
74
-
| None -> cmd
75
-
in
26
+
| Options.Wire.User -> "user"
27
+
| Options.Wire.Project -> "project"
28
+
| Options.Wire.Local -> "local"
76
29
77
-
(* Advanced configuration options *)
78
-
let cmd =
79
-
match Options.max_budget_usd options with
80
-
| Some budget -> cmd @ [ "--max-budget-usd"; Float.to_string budget ]
81
-
| None -> cmd
82
-
in
30
+
let add_flag flag opt cmd =
31
+
match opt with None -> cmd | Some v -> cmd @ [ flag; v ]
83
32
84
-
let cmd =
85
-
match Options.fallback_model options with
86
-
| Some model -> cmd @ [ "--fallback-model"; Model.to_string model ]
87
-
| None -> cmd
88
-
in
33
+
let add_list flag list cmd =
34
+
match list with [] -> cmd | items -> cmd @ [ flag; String.concat "," items ]
89
35
90
-
let cmd =
91
-
match Options.setting_sources options with
92
-
| Some sources ->
93
-
let sources_str =
94
-
String.concat "," (List.map setting_source_to_string sources)
95
-
in
96
-
cmd @ [ "--setting-sources"; sources_str ]
97
-
| None -> cmd
98
-
in
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
+
Json.Value.to_string schema)
61
+
(Options.output_format options))
62
+
|> fun cmd -> cmd @ [ "--input-format"; "stream-json" ]
99
63
100
-
(* Add JSON Schema if specified *)
101
-
let cmd =
102
-
match Options.output_format options with
103
-
| Some format ->
104
-
let schema = Proto.Structured_output.to_json_schema format in
105
-
let schema_str =
106
-
match Jsont_bytesrw.encode_string' Jsont.json schema with
107
-
| Ok s -> s
108
-
| Error err -> failwith (Jsont.Error.to_string err)
109
-
in
110
-
cmd @ [ "--json-schema"; schema_str ]
111
-
| None -> cmd
112
-
in
113
-
114
-
(* Use streaming input mode *)
115
-
cmd @ [ "--input-format"; "stream-json" ]
116
-
117
-
let create ~sw ~process_mgr ~options () =
118
-
let claude_path = "claude" in
119
-
let cmd = build_command ~claude_path ~options in
120
-
121
-
(* Build environment - preserve essential vars for Claude config/auth access *)
64
+
let build_environment ~options =
65
+
(* Preserve essential vars for Claude config/auth access *)
122
66
let home = Option.value (Sys.getenv_opt "HOME") ~default:"/tmp" in
123
67
let path = Option.value (Sys.getenv_opt "PATH") ~default:"/usr/bin:/bin" in
124
68
···
140
84
let preserved =
141
85
List.filter_map
142
86
(fun var ->
143
-
Option.map
144
-
(fun value -> Printf.sprintf "%s=%s" var value)
145
-
(Sys.getenv_opt var))
87
+
Option.map (fun value -> Fmt.str "%s=%s" var value) (Sys.getenv_opt var))
146
88
preserve_vars
147
89
in
148
90
149
91
let base_env =
150
92
[
151
-
Printf.sprintf "HOME=%s" home;
152
-
Printf.sprintf "PATH=%s" path;
93
+
Fmt.str "HOME=%s" home;
94
+
Fmt.str "PATH=%s" path;
153
95
"CLAUDE_CODE_ENTRYPOINT=sdk-ocaml";
154
96
]
155
97
@ preserved
156
98
in
157
99
158
100
let custom_env =
159
-
List.map (fun (k, v) -> Printf.sprintf "%s=%s" k v) (Options.env options)
101
+
List.map (fun (k, v) -> Fmt.str "%s=%s" k v) (Options.env options)
160
102
in
161
103
let env = Array.of_list (base_env @ custom_env) in
162
104
Log.debug (fun m -> m "Environment: HOME=%s, PATH=%s" home path);
163
105
Log.info (fun m ->
164
106
m "Full environment variables: %s"
165
107
(String.concat ", " (Array.to_list env)));
108
+
env
109
+
110
+
let spawn_process ~sw ~process_mgr ~env ~options ~cmd ~stdin_r ~stdout_w =
111
+
try
112
+
Log.info (fun m ->
113
+
m "Spawning claude with command: %s" (String.concat " " cmd));
114
+
Log.info (fun m -> m "Command arguments breakdown:");
115
+
List.iteri (fun i arg -> Log.info (fun m -> m " [%d]: %s" i arg)) cmd;
116
+
Eio.Process.spawn ~sw process_mgr ~env
117
+
~stdin:(stdin_r :> Eio.Flow.source_ty r)
118
+
~stdout:(stdout_w :> Eio.Flow.sink_ty r)
119
+
?cwd:(Options.cwd options) cmd
120
+
with exn ->
121
+
Log.err (fun m ->
122
+
m "Failed to spawn claude CLI: %s" (Printexc.to_string exn));
123
+
Log.err (fun m -> m "Make sure 'claude' is installed and authenticated");
124
+
Log.err (fun m -> m "You may need to run 'claude login' first");
125
+
raise
126
+
(CLI_not_found
127
+
(Fmt.str "Failed to spawn claude CLI: %s" (Printexc.to_string exn)))
128
+
129
+
let v ~sw ~process_mgr ~options () =
130
+
let claude_path = "claude" in
131
+
let cmd = build_command ~claude_path ~options in
132
+
let env = build_environment ~options in
166
133
167
134
let stdin_r, stdin_w = Eio.Process.pipe ~sw process_mgr in
168
135
let stdout_r, stdout_w = Eio.Process.pipe ~sw process_mgr in
···
172
139
Eio.Flow.close stderr_w;
173
140
174
141
let process =
175
-
try
176
-
Log.info (fun m ->
177
-
m "Spawning claude with command: %s" (String.concat " " cmd));
178
-
Log.info (fun m -> m "Command arguments breakdown:");
179
-
List.iteri (fun i arg -> Log.info (fun m -> m " [%d]: %s" i arg)) cmd;
180
-
Eio.Process.spawn ~sw process_mgr ~env
181
-
~stdin:(stdin_r :> Eio.Flow.source_ty r)
182
-
~stdout:(stdout_w :> Eio.Flow.sink_ty r)
183
-
?cwd:(Options.cwd options) cmd
184
-
with exn ->
185
-
Log.err (fun m ->
186
-
m "Failed to spawn claude CLI: %s" (Printexc.to_string exn));
187
-
Log.err (fun m -> m "Make sure 'claude' is installed and authenticated");
188
-
Log.err (fun m -> m "You may need to run 'claude login' first");
189
-
raise
190
-
(CLI_not_found
191
-
(Printf.sprintf "Failed to spawn claude CLI: %s"
192
-
(Printexc.to_string exn)))
142
+
spawn_process ~sw ~process_mgr ~env ~options ~cmd ~stdin_r ~stdout_w
193
143
in
194
144
195
145
let stdin = (stdin_w :> Eio.Flow.sink_ty r) in
···
206
156
{ process = P process; stdin; stdin_close; stdout }
207
157
208
158
let send t json =
209
-
let data =
210
-
match Jsont_bytesrw.encode_string' Jsont.json json with
211
-
| Ok s -> s
212
-
| Error err -> failwith (Jsont.Error.to_string err)
213
-
in
159
+
let data = Json.Value.to_string json in
214
160
Log.debug (fun m -> m "Sending: %s" data);
215
161
try Eio.Flow.write t.stdin [ Cstruct.of_string (data ^ "\n") ]
216
162
with exn ->
217
163
Log.err (fun m -> m "Failed to send message: %s" (Printexc.to_string exn));
218
164
raise
219
165
(Connection_error
220
-
(Printf.sprintf "Failed to send message: %s" (Printexc.to_string exn)))
166
+
(Fmt.str "Failed to send message: %s" (Printexc.to_string exn)))
221
167
222
168
let receive_line t =
223
169
try
···
233
179
m "Failed to receive message: %s" (Printexc.to_string exn));
234
180
raise
235
181
(Connection_error
236
-
(Printf.sprintf "Failed to receive message: %s"
237
-
(Printexc.to_string exn)))
182
+
(Fmt.str "Failed to receive message: %s" (Printexc.to_string exn)))
238
183
239
184
let interrupt t =
240
185
Log.info (fun m -> m "Sending interrupt signal");
241
-
(* Create interrupt request using Proto types *)
242
-
let request = Proto.Control.Request.interrupt () in
243
-
let envelope = Proto.Control.create_request ~request_id:"" ~request () in
244
-
let outgoing = Proto.Outgoing.Control_request envelope in
245
-
let interrupt_msg = Proto.Outgoing.to_json outgoing in
186
+
let request = Control.Request.interrupt () in
187
+
let envelope : Control.control_request =
188
+
{
189
+
type_ = `Control_request;
190
+
request_id = "";
191
+
request;
192
+
unknown = Unknown.empty;
193
+
}
194
+
in
195
+
let outgoing = Outgoing.Control_request envelope in
196
+
let interrupt_msg = Outgoing.to_json outgoing in
246
197
send t interrupt_msg
247
198
248
199
let close t =
···
250
201
Eio.Flow.close t.stdin_close;
251
202
let (P process) = t.process in
252
203
Eio.Process.await_exn process
253
-
with _ -> ()
204
+
with Eio.Io _ -> ()
+13
-3
lib/transport.mli
+13
-3
lib/transport.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
+
(** Claude CLI process transport. *)
7
+
6
8
val src : Logs.Src.t
7
-
(** The log source for transport operations *)
9
+
(** The log source for transport operations. *)
8
10
9
11
exception CLI_not_found of string
10
12
exception Process_error of string
···
12
14
13
15
type t
14
16
15
-
val create :
17
+
val v :
16
18
sw:Eio.Switch.t ->
17
19
process_mgr:_ Eio.Process.mgr ->
18
20
options:Options.t ->
19
21
unit ->
20
22
t
23
+
(** [v ~sw ~process_mgr ~options ()] creates a new transport. *)
21
24
22
-
val send : t -> Jsont.json -> unit
25
+
val send : t -> Json.t -> unit
26
+
(** Send a JSON message. *)
27
+
23
28
val receive_line : t -> string option
29
+
(** Receive a line from the transport. *)
30
+
24
31
val interrupt : t -> unit
32
+
(** Send an interrupt signal. *)
33
+
25
34
val close : t -> unit
35
+
(** Close the transport. *)
+43
-14
lib/unknown.ml
+43
-14
lib/unknown.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Unknown fields for capturing extra JSON object members.
6
+
type t = (string * Json.t) list
7
7
8
-
This module provides a type and utilities for preserving unknown/extra
9
-
fields when parsing JSON objects with jsont. Use with
10
-
[Jsont.Object.keep_unknown] to capture fields not explicitly defined in your
11
-
codec. *)
8
+
let pp ppf t =
9
+
let pp_pair ppf (k, v) = Fmt.pf ppf "@[%s: %a@]" k Json.pp v in
10
+
Fmt.pf ppf "@[{%a}@]"
11
+
(Fmt.list ~sep:(fun ppf () -> Fmt.pf ppf ",@ ") pp_pair)
12
+
t
12
13
13
-
type t = Jsont.json
14
-
(** The type of unknown fields - stored as raw JSON. *)
14
+
let empty = []
15
+
let is_empty = function [] -> true | _ -> false
16
+
let of_assoc x = x
17
+
let to_assoc x = x
15
18
16
-
(** An empty unknown fields value (empty JSON object). *)
17
-
let empty = Jsont.Object ([], Jsont.Meta.none)
18
-
19
-
(** [is_empty t] returns [true] if there are no unknown fields. *)
20
-
let is_empty = function Jsont.Object ([], _) -> true | _ -> false
19
+
let json =
20
+
let open Json.Codec in
21
+
let dec obj =
22
+
match obj with
23
+
| Json.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, Json.Meta.none), json)) fields
30
+
in
31
+
Json.Object (mems, Json.Meta.none)
32
+
in
33
+
map ~dec ~enc Value.t
21
34
22
-
(** Codec for unknown fields. *)
23
-
let jsont = Jsont.json
35
+
let mems : (t, Json.t, Json.member list) Json.Codec.Object.Members.map =
36
+
let open Json.Codec 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.Members.enc =
45
+
(fun k fields acc ->
46
+
List.fold_left
47
+
(fun acc (name, json) -> k Json.Meta.none name json acc)
48
+
acc fields);
49
+
}
50
+
in
51
+
Object.Members.map ~kind:"Unknown" ~dec_empty ~dec_add ~dec_finish ~enc
52
+
Value.t
+24
-11
lib/unknown.mli
+24
-11
lib/unknown.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Unknown fields for capturing extra JSON object members.
6
+
(** Unknown fields for preserving extra JSON object members during
7
+
round-tripping.
7
8
8
-
This module provides a type and utilities for preserving unknown/extra
9
-
fields when parsing JSON objects with jsont. Use with
10
-
[Jsont.Object.keep_unknown] to capture fields not explicitly defined in your
11
-
codec. *)
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. *)
12
16
13
-
type t = Jsont.json
14
-
(** The type of unknown fields - stored as raw JSON. *)
17
+
val pp : Format.formatter -> t -> unit
18
+
(** [pp ppf t] pretty-prints the unknown fields. *)
15
19
16
20
val empty : t
17
-
(** An empty unknown fields value (empty JSON object). *)
21
+
(** [empty] is an empty set of unknown fields. *)
18
22
19
23
val is_empty : t -> bool
20
-
(** [is_empty t] returns [true] if there are no unknown fields. *)
24
+
(** [is_empty t] returns [true] if there are no unknown fields stored in [t]. *)
25
+
26
+
val of_assoc : (string * Json.t) list -> t
27
+
(** [of_assoc assoc] creates unknown fields from an association list. *)
28
+
29
+
val to_assoc : t -> (string * Json.t) list
30
+
(** [to_assoc t] returns the association list of unknown fields. *)
21
31
22
-
val jsont : t Jsont.t
23
-
(** Codec for unknown fields. *)
32
+
val json : t Json.codec
33
+
(** [json] is a codec for encoding and decoding unknown fields to/from JSON. *)
34
+
35
+
val mems : (t, Json.t, Json.member list) Json.Codec.Object.Members.map
36
+
(** [mems] is a mems codec for use with [Json.Codec.Object.keep_unknown]. *)
+2
-106
test/dune
+2
-106
test/dune
···
1
-
(library
2
-
(name test_json_utils)
3
-
(modules test_json_utils)
4
-
(libraries jsont jsont.bytesrw))
5
-
6
-
; Consolidated unit test suite using alcotest
7
-
8
1
(test
9
-
(name test_claude)
10
-
(modules test_claude)
11
-
(libraries claude alcotest jsont.bytesrw))
12
-
13
-
(executable
14
-
(name camel_jokes)
15
-
(modules camel_jokes)
16
-
(libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
17
-
18
-
(executable
19
-
(name permission_demo)
20
-
(modules permission_demo)
21
-
(libraries
22
-
test_json_utils
23
-
claude
24
-
eio_main
25
-
cmdliner
26
-
logs
27
-
logs.fmt
28
-
fmt.tty
29
-
fmt.cli
30
-
logs.cli))
31
-
32
-
(executable
33
-
(name discovery_demo)
34
-
(modules discovery_demo)
35
-
(libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
36
-
37
-
(executable
38
-
(name simulated_permissions)
39
-
(modules simulated_permissions)
40
-
(libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
41
-
42
-
(executable
43
-
(name test_permissions)
44
-
(modules test_permissions)
45
-
(libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
46
-
47
-
(executable
48
-
(name simple_permission_test)
49
-
(modules simple_permission_test)
50
-
(libraries
51
-
test_json_utils
52
-
claude
53
-
eio_main
54
-
cmdliner
55
-
logs
56
-
logs.fmt
57
-
fmt.tty
58
-
fmt.cli
59
-
logs.cli))
60
-
61
-
(executable
62
-
(name hooks_example)
63
-
(modules hooks_example)
64
-
(libraries
65
-
test_json_utils
66
-
claude
67
-
eio_main
68
-
cmdliner
69
-
logs
70
-
logs.fmt
71
-
fmt.tty
72
-
fmt.cli
73
-
logs.cli))
74
-
75
-
(executable
76
-
(name dynamic_control_demo)
77
-
(modules dynamic_control_demo)
78
-
(libraries claude eio_main cmdliner logs logs.fmt fmt.tty fmt.cli logs.cli))
79
-
80
-
(executable
81
-
(name advanced_config_demo)
82
-
(modules advanced_config_demo)
83
-
(libraries claude eio_main logs logs.fmt fmt.tty))
84
-
85
-
(executable
86
-
(name structured_output_demo)
87
-
(modules structured_output_demo)
88
-
(flags
89
-
(:standard -w -33))
90
-
(libraries test_json_utils claude eio_main logs logs.fmt fmt.tty))
91
-
92
-
(executable
93
-
(name structured_output_simple)
94
-
(modules structured_output_simple)
95
-
(flags
96
-
(:standard -w -33))
97
-
(libraries test_json_utils claude eio_main logs logs.fmt fmt.tty))
98
-
99
-
(executable
100
-
(name test_incoming)
101
-
(modules test_incoming)
102
-
(libraries claude jsont.bytesrw))
103
-
104
-
(executable
105
-
(name test_structured_error)
106
-
(modules test_structured_error)
107
-
(libraries claude eio_main jsont.bytesrw))
2
+
(name test)
3
+
(libraries claude alcotest vlog nox-loc))
+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
+154
test/interop/python_sdk/test.ml
+154
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 Json.Value.of_string (read_file path) with
35
+
| Ok json -> json
36
+
| Error e -> Alcotest.failf "load %s: %s" path (Json.Error.to_string e)
37
+
38
+
let canonicalise json =
39
+
let rec go = function
40
+
| Json.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
+
Json.String ("REQ_ID", Json.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
+
Json.Object (sorted, meta)
56
+
| Json.Array (xs, meta) -> Json.Array (List.map go xs, meta)
57
+
| other -> other
58
+
in
59
+
go json
60
+
61
+
let to_string j = Json.Value.to_string j
62
+
63
+
let assert_equal ~name ~expected ~got =
64
+
let e = to_string (canonicalise expected) in
65
+
let g = to_string (canonicalise got) in
66
+
if e <> g then
67
+
Alcotest.failf "%s mismatch:\n python: %s\n ocaml: %s" name e g
68
+
69
+
let envelope ~request =
70
+
let env : C.control_request =
71
+
{
72
+
type_ = `Control_request;
73
+
request_id = "REQ_ID";
74
+
request;
75
+
unknown = Claude.Unknown.empty;
76
+
}
77
+
in
78
+
Claude.Outgoing.to_json (Claude.Outgoing.Control_request env)
79
+
80
+
let test_interrupt () =
81
+
let expected = trace "interrupt" in
82
+
let got = envelope ~request:(C.Request.interrupt ()) in
83
+
assert_equal ~name:"interrupt" ~expected ~got
84
+
85
+
let test_set_model_some () =
86
+
let expected = trace "set_model_some" in
87
+
let got =
88
+
envelope ~request:(C.Request.set_model ~model:"claude-sonnet-4-5" ())
89
+
in
90
+
assert_equal ~name:"set_model_some" ~expected ~got
91
+
92
+
let test_set_permission_mode () =
93
+
let expected = trace "set_permission_mode" in
94
+
let got =
95
+
envelope ~request:(C.Request.set_permission_mode ~mode:M.Accept_edits ())
96
+
in
97
+
assert_equal ~name:"set_permission_mode" ~expected ~got
98
+
99
+
let json_object mems =
100
+
Json.Object
101
+
(List.map (fun (k, v) -> ((k, Json.Meta.none), v)) mems, Json.Meta.none)
102
+
103
+
let json_string s = Json.String (s, Json.Meta.none)
104
+
let json_int n = Json.Number (float_of_int n, Json.Meta.none)
105
+
let json_array xs = Json.Array (xs, Json.Meta.none)
106
+
107
+
let test_initialize () =
108
+
let expected = trace "initialize" in
109
+
let pre_tool_use =
110
+
json_array
111
+
[
112
+
json_object
113
+
[
114
+
("hookCallbackIds", json_array [ json_string "hook_0" ]);
115
+
("matcher", json_string "Bash");
116
+
("timeout", json_int 5000);
117
+
];
118
+
]
119
+
in
120
+
let hooks = [ ("PreToolUse", pre_tool_use) ] in
121
+
let got = envelope ~request:(C.Request.initialize ~hooks ()) in
122
+
assert_equal ~name:"initialize" ~expected ~got
123
+
124
+
let test_documents_unsupported subtype () =
125
+
(* These subtypes are emitted by claude-agent-sdk but not yet modelled
126
+
by Claude.Control.Request. The trace exists so the gap is visible;
127
+
OCaml cannot build them today. *)
128
+
let _ = trace subtype in
129
+
Alcotest.skip ()
130
+
131
+
let suite =
132
+
( "python_sdk_interop",
133
+
[
134
+
Alcotest.test_case "interrupt" `Quick test_interrupt;
135
+
Alcotest.test_case "set_model (some)" `Quick test_set_model_some;
136
+
Alcotest.test_case "set_permission_mode" `Quick test_set_permission_mode;
137
+
Alcotest.test_case "initialize" `Quick test_initialize;
138
+
Alcotest.test_case "set_model (none) - unsupported" `Quick
139
+
(test_documents_unsupported "set_model_none");
140
+
Alcotest.test_case "mcp_status - unsupported" `Quick
141
+
(test_documents_unsupported "mcp_status");
142
+
Alcotest.test_case "context_usage - unsupported" `Quick
143
+
(test_documents_unsupported "context_usage");
144
+
Alcotest.test_case "rewind_files - unsupported" `Quick
145
+
(test_documents_unsupported "rewind_files");
146
+
Alcotest.test_case "reconnect_mcp - unsupported" `Quick
147
+
(test_documents_unsupported "reconnect_mcp");
148
+
Alcotest.test_case "toggle_mcp_off - unsupported" `Quick
149
+
(test_documents_unsupported "toggle_mcp_off");
150
+
Alcotest.test_case "stop_task - unsupported" `Quick
151
+
(test_documents_unsupported "stop_task");
152
+
] )
153
+
154
+
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_error.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
+
]
+144
-168
test/test_claude.ml
+144
-168
test/test_claude.ml
···
11
11
- Mcp_server module for in-process MCP servers
12
12
- Structured error handling *)
13
13
14
-
module J = Jsont.Json
14
+
module J = Json.Value
15
15
16
16
(* ============================================
17
17
Protocol Tests - Incoming message codec
···
20
20
let test_decode_user_message () =
21
21
(* User messages from CLI come wrapped in a "message" envelope *)
22
22
let json_str = {|{"type":"user","message":{"content":"Hello"}}|} in
23
-
match Jsont_bytesrw.decode_string' Claude.Proto.Incoming.jsont json_str with
24
-
| Ok (Claude.Proto.Incoming.Message (Claude.Proto.Message.User _)) -> ()
23
+
match Json.of_string Claude.Incoming.json json_str with
24
+
| Ok (Claude.Incoming.Message (Claude.Message.User _)) -> ()
25
25
| Ok _ -> Alcotest.fail "Wrong message type decoded"
26
-
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
26
+
| Error err -> Alcotest.fail (Json.Error.to_string err)
27
27
28
28
let test_decode_assistant_message () =
29
29
(* Assistant messages from CLI come wrapped in a "message" envelope *)
30
30
let json_str =
31
31
{|{"type":"assistant","message":{"model":"claude-sonnet-4","content":[{"type":"text","text":"Hi"}]}}|}
32
32
in
33
-
match Jsont_bytesrw.decode_string' Claude.Proto.Incoming.jsont json_str with
34
-
| Ok (Claude.Proto.Incoming.Message (Claude.Proto.Message.Assistant _)) -> ()
33
+
match Json.of_string Claude.Incoming.json json_str with
34
+
| Ok (Claude.Incoming.Message (Claude.Message.Assistant _)) -> ()
35
35
| Ok _ -> Alcotest.fail "Wrong message type decoded"
36
-
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
36
+
| Error err -> Alcotest.fail (Json.Error.to_string err)
37
37
38
38
let test_decode_system_message () =
39
39
let json_str =
40
40
{|{"type":"system","subtype":"init","data":{"session_id":"test-123"}}|}
41
41
in
42
-
match Jsont_bytesrw.decode_string' Claude.Proto.Incoming.jsont json_str with
43
-
| Ok (Claude.Proto.Incoming.Message (Claude.Proto.Message.System _)) -> ()
42
+
match Json.of_string Claude.Incoming.json json_str with
43
+
| Ok (Claude.Incoming.Message (Claude.Message.System _)) -> ()
44
44
| Ok _ -> Alcotest.fail "Wrong message type decoded"
45
-
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
45
+
| Error err -> Alcotest.fail (Json.Error.to_string err)
46
46
47
47
let test_decode_control_response_success () =
48
48
let json_str =
49
-
{|{"type":"control_response","response":{"subtype":"success","requestId":"test-req-1"}}|}
49
+
{|{"type":"control_response","response":{"subtype":"success","request_id":"test-req-1"}}|}
50
50
in
51
-
match Jsont_bytesrw.decode_string' Claude.Proto.Incoming.jsont json_str with
52
-
| Ok (Claude.Proto.Incoming.Control_response resp) -> (
51
+
match Json.of_string Claude.Incoming.json json_str with
52
+
| Ok (Claude.Incoming.Control_response resp) -> (
53
53
match resp.response with
54
-
| Claude.Proto.Control.Response.Success s ->
54
+
| Claude.Control.Response.Success s ->
55
55
Alcotest.(check string) "request_id" "test-req-1" s.request_id
56
-
| Claude.Proto.Control.Response.Error _ ->
56
+
| Claude.Control.Response.Error _ ->
57
57
Alcotest.fail "Got error response instead of success")
58
58
| Ok _ -> Alcotest.fail "Wrong message type decoded"
59
-
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
59
+
| Error err -> Alcotest.fail (Json.Error.to_string err)
60
60
61
61
let test_decode_control_response_error () =
62
62
let json_str =
63
-
{|{"type":"control_response","response":{"subtype":"error","requestId":"test-req-2","error":{"code":-32603,"message":"Something went wrong"}}}|}
63
+
{|{"type":"control_response","response":{"subtype":"error","request_id":"test-req-2","error":{"code":-32603,"message":"Something went wrong"}}}|}
64
64
in
65
-
match Jsont_bytesrw.decode_string' Claude.Proto.Incoming.jsont json_str with
66
-
| Ok (Claude.Proto.Incoming.Control_response resp) -> (
65
+
match Json.of_string Claude.Incoming.json json_str with
66
+
| Ok (Claude.Incoming.Control_response resp) -> (
67
67
match resp.response with
68
-
| Claude.Proto.Control.Response.Error e ->
68
+
| Claude.Control.Response.Error e ->
69
69
Alcotest.(check string) "request_id" "test-req-2" e.request_id;
70
70
Alcotest.(check int) "error code" (-32603) e.error.code;
71
71
Alcotest.(check string)
72
72
"error message" "Something went wrong" e.error.message
73
-
| Claude.Proto.Control.Response.Success _ ->
73
+
| Claude.Control.Response.Success _ ->
74
74
Alcotest.fail "Got success response instead of error")
75
75
| Ok _ -> Alcotest.fail "Wrong message type decoded"
76
-
| Error err -> Alcotest.fail (Jsont.Error.to_string err)
76
+
| Error err -> Alcotest.fail (Json.Error.to_string err)
77
77
78
78
let protocol_tests =
79
79
[
···
93
93
94
94
let json_testable =
95
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)
96
+
(fun fmt json -> Format.pp_print_string fmt (Json.Value.to_string json))
97
+
(fun a b -> String.equal (Json.Value.to_string a) (Json.Value.to_string b))
107
98
108
99
let test_tool_schema_string () =
109
100
let schema = Claude.Tool.schema_string in
110
-
let expected = J.object' [ J.mem (J.name "type") (J.string "string") ] in
101
+
let expected = J.object' [ J.member (J.name "type") (J.string "string") ] in
111
102
Alcotest.check json_testable "schema_string" expected schema
112
103
113
104
let test_tool_schema_int () =
114
105
let schema = Claude.Tool.schema_int in
115
-
let expected = J.object' [ J.mem (J.name "type") (J.string "integer") ] in
106
+
let expected = J.object' [ J.member (J.name "type") (J.string "integer") ] in
116
107
Alcotest.check json_testable "schema_int" expected schema
117
108
118
109
let test_tool_schema_number () =
119
110
let schema = Claude.Tool.schema_number in
120
-
let expected = J.object' [ J.mem (J.name "type") (J.string "number") ] in
111
+
let expected = J.object' [ J.member (J.name "type") (J.string "number") ] in
121
112
Alcotest.check json_testable "schema_number" expected schema
122
113
123
114
let test_tool_schema_bool () =
124
115
let schema = Claude.Tool.schema_bool in
125
-
let expected = J.object' [ J.mem (J.name "type") (J.string "boolean") ] in
116
+
let expected = J.object' [ J.member (J.name "type") (J.string "boolean") ] in
126
117
Alcotest.check json_testable "schema_bool" expected schema
127
118
128
119
let test_tool_schema_array () =
···
130
121
let expected =
131
122
J.object'
132
123
[
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") ]);
124
+
J.member (J.name "type") (J.string "array");
125
+
J.member (J.name "items")
126
+
(J.object' [ J.member (J.name "type") (J.string "string") ]);
136
127
]
137
128
in
138
129
Alcotest.check json_testable "schema_array" expected schema
···
142
133
let expected =
143
134
J.object'
144
135
[
145
-
J.mem (J.name "type") (J.string "string");
146
-
J.mem (J.name "enum")
136
+
J.member (J.name "type") (J.string "string");
137
+
J.member (J.name "enum")
147
138
(J.list [ J.string "foo"; J.string "bar"; J.string "baz" ]);
148
139
]
149
140
in
···
158
149
let expected =
159
150
J.object'
160
151
[
161
-
J.mem (J.name "type") (J.string "object");
162
-
J.mem (J.name "properties")
152
+
J.member (J.name "type") (J.string "object");
153
+
J.member (J.name "properties")
163
154
(J.object'
164
155
[
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") ]);
156
+
J.member (J.name "name")
157
+
(J.object' [ J.member (J.name "type") (J.string "string") ]);
158
+
J.member (J.name "age")
159
+
(J.object' [ J.member (J.name "type") (J.string "integer") ]);
169
160
]);
170
-
J.mem (J.name "required") (J.list [ J.string "name" ]);
161
+
J.member (J.name "required") (J.list [ J.string "name" ]);
171
162
]
172
163
in
173
164
Alcotest.check json_testable "schema_object" expected schema
···
179
170
[
180
171
J.object'
181
172
[
182
-
J.mem (J.name "type") (J.string "text");
183
-
J.mem (J.name "text") (J.string "Hello, world!");
173
+
J.member (J.name "type") (J.string "text");
174
+
J.member (J.name "text") (J.string "Hello, world!");
184
175
];
185
176
]
186
177
in
···
193
184
[
194
185
J.object'
195
186
[
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);
187
+
J.member (J.name "type") (J.string "text");
188
+
J.member (J.name "text") (J.string "Something went wrong");
189
+
J.member (J.name "is_error") (J.bool true);
199
190
];
200
191
]
201
192
in
···
203
194
204
195
let test_tool_create_and_call () =
205
196
let greet =
206
-
Claude.Tool.create ~name:"greet" ~description:"Greet a user"
197
+
Claude.Tool.v ~name:"greet" ~description:"Greet a user"
207
198
~input_schema:
208
199
(Claude.Tool.schema_object
209
200
[ ("name", Claude.Tool.schema_string) ]
210
201
~required:[ "name" ])
211
202
~handler:(fun args ->
212
-
match Claude.Tool_input.get_string args "name" with
203
+
match Claude.Tool_input.string args "name" with
213
204
| Some name -> Ok (Claude.Tool.text_result ("Hello, " ^ name ^ "!"))
214
205
| None -> Error "Missing name parameter")
215
206
in
···
219
210
(Claude.Tool.description greet);
220
211
221
212
(* Test successful call *)
222
-
let input_json = J.object' [ J.mem (J.name "name") (J.string "Alice") ] in
213
+
let input_json = J.object' [ J.member (J.name "name") (J.string "Alice") ] in
223
214
let input = Claude.Tool_input.of_json input_json in
224
215
match Claude.Tool.call greet input with
225
216
| Ok result ->
···
229
220
230
221
let test_tool_call_error () =
231
222
let tool =
232
-
Claude.Tool.create ~name:"fail" ~description:"Always fails"
223
+
Claude.Tool.v ~name:"fail" ~description:"Always fails"
233
224
~input_schema:(Claude.Tool.schema_object [] ~required:[])
234
225
~handler:(fun _ -> Error "Intentional failure")
235
226
in
···
260
251
261
252
let test_mcp_server_create () =
262
253
let tool =
263
-
Claude.Tool.create ~name:"echo" ~description:"Echo input"
254
+
Claude.Tool.v ~name:"echo" ~description:"Echo input"
264
255
~input_schema:
265
256
(Claude.Tool.schema_object
266
257
[ ("text", Claude.Tool.schema_string) ]
267
258
~required:[ "text" ])
268
259
~handler:(fun args ->
269
-
match Claude.Tool_input.get_string args "text" with
260
+
match Claude.Tool_input.string args "text" with
270
261
| Some text -> Ok (Claude.Tool.text_result text)
271
262
| None -> Error "Missing text")
272
263
in
273
264
let server =
274
-
Claude.Mcp_server.create ~name:"test-server" ~version:"2.0.0"
275
-
~tools:[ tool ] ()
265
+
Claude.Mcp_server.v ~name:"test-server" ~version:"2.0.0" ~tools:[ tool ] ()
276
266
in
277
267
Alcotest.(check string)
278
268
"server name" "test-server"
···
285
275
(List.length (Claude.Mcp_server.tools server))
286
276
287
277
let test_mcp_server_initialize () =
288
-
let server = Claude.Mcp_server.create ~name:"init-test" ~tools:[] () in
278
+
let server = Claude.Mcp_server.v ~name:"init-test" ~tools:[] () in
289
279
let request =
290
280
J.object'
291
281
[
292
-
J.mem (J.name "jsonrpc") (J.string "2.0");
293
-
J.mem (J.name "id") (J.number 1.0);
294
-
J.mem (J.name "method") (J.string "initialize");
295
-
J.mem (J.name "params") (J.object' []);
282
+
J.member (J.name "jsonrpc") (J.string "2.0");
283
+
J.member (J.name "id") (J.number 1.0);
284
+
J.member (J.name "method") (J.string "initialize");
285
+
J.member (J.name "params") (J.object' []);
296
286
]
297
287
in
298
288
let response = Claude.Mcp_server.handle_json_message server request in
299
289
(* Check it's a success response with serverInfo *)
300
290
match response with
301
-
| Jsont.Object (mems, _) ->
291
+
| Json.Object (mems, _) ->
302
292
let has_result = List.exists (fun ((k, _), _) -> k = "result") mems in
303
293
Alcotest.(check bool) "has result" true has_result
304
294
| _ -> Alcotest.fail "Expected object response"
305
295
306
296
let test_mcp_server_tools_list () =
307
297
let tool =
308
-
Claude.Tool.create ~name:"my_tool" ~description:"My test tool"
298
+
Claude.Tool.v ~name:"my_tool" ~description:"My test tool"
309
299
~input_schema:(Claude.Tool.schema_object [] ~required:[])
310
300
~handler:(fun _ -> Ok (Claude.Tool.text_result "ok"))
311
301
in
312
-
let server = Claude.Mcp_server.create ~name:"list-test" ~tools:[ tool ] () in
302
+
let server = Claude.Mcp_server.v ~name:"list-test" ~tools:[ tool ] () in
313
303
let request =
314
304
J.object'
315
305
[
316
-
J.mem (J.name "jsonrpc") (J.string "2.0");
317
-
J.mem (J.name "id") (J.number 2.0);
318
-
J.mem (J.name "method") (J.string "tools/list");
319
-
J.mem (J.name "params") (J.object' []);
306
+
J.member (J.name "jsonrpc") (J.string "2.0");
307
+
J.member (J.name "id") (J.number 2.0);
308
+
J.member (J.name "method") (J.string "tools/list");
309
+
J.member (J.name "params") (J.object' []);
320
310
]
321
311
in
322
312
let response = Claude.Mcp_server.handle_json_message server request in
323
313
match response with
324
-
| Jsont.Object (mems, _) -> (
314
+
| Json.Object (mems, _) -> (
325
315
match List.find_opt (fun ((k, _), _) -> k = "result") mems with
326
-
| Some (_, Jsont.Object (result_mems, _)) -> (
316
+
| Some (_, Json.Object (result_mems, _)) -> (
327
317
match List.find_opt (fun ((k, _), _) -> k = "tools") result_mems with
328
-
| Some (_, Jsont.Array (tools, _)) ->
318
+
| Some (_, Json.Array (tools, _)) ->
329
319
Alcotest.(check int) "tools count" 1 (List.length tools)
330
320
| _ -> Alcotest.fail "Missing tools in result")
331
321
| _ -> Alcotest.fail "Missing result in response")
···
333
323
334
324
let test_mcp_server_tools_call () =
335
325
let tool =
336
-
Claude.Tool.create ~name:"uppercase" ~description:"Convert to uppercase"
326
+
Claude.Tool.v ~name:"uppercase" ~description:"Convert to uppercase"
337
327
~input_schema:
338
328
(Claude.Tool.schema_object
339
329
[ ("text", Claude.Tool.schema_string) ]
340
330
~required:[ "text" ])
341
331
~handler:(fun args ->
342
-
match Claude.Tool_input.get_string args "text" with
332
+
match Claude.Tool_input.string args "text" with
343
333
| Some text ->
344
334
Ok (Claude.Tool.text_result (String.uppercase_ascii text))
345
335
| None -> Error "Missing text")
346
336
in
347
-
let server = Claude.Mcp_server.create ~name:"call-test" ~tools:[ tool ] () in
337
+
let server = Claude.Mcp_server.v ~name:"call-test" ~tools:[ tool ] () in
348
338
let request =
349
339
J.object'
350
340
[
351
-
J.mem (J.name "jsonrpc") (J.string "2.0");
352
-
J.mem (J.name "id") (J.number 3.0);
353
-
J.mem (J.name "method") (J.string "tools/call");
354
-
J.mem (J.name "params")
341
+
J.member (J.name "jsonrpc") (J.string "2.0");
342
+
J.member (J.name "id") (J.number 3.0);
343
+
J.member (J.name "method") (J.string "tools/call");
344
+
J.member (J.name "params")
355
345
(J.object'
356
346
[
357
-
J.mem (J.name "name") (J.string "uppercase");
358
-
J.mem (J.name "arguments")
359
-
(J.object' [ J.mem (J.name "text") (J.string "hello") ]);
347
+
J.member (J.name "name") (J.string "uppercase");
348
+
J.member (J.name "arguments")
349
+
(J.object' [ J.member (J.name "text") (J.string "hello") ]);
360
350
]);
361
351
]
362
352
in
363
353
let response = Claude.Mcp_server.handle_json_message server request in
364
354
(* Verify it contains the expected uppercase result *)
365
-
let response_str =
366
-
match Jsont_bytesrw.encode_string' Jsont.json response with
367
-
| Ok s -> s
368
-
| Error _ -> ""
369
-
in
355
+
let response_str = Json.Value.to_string response in
370
356
(* Simple substring check for HELLO in response *)
371
357
let contains_hello =
372
358
let rec check i =
···
378
364
in
379
365
Alcotest.(check bool) "contains HELLO" true contains_hello
380
366
381
-
let test_mcp_server_tool_not_found () =
382
-
let server = Claude.Mcp_server.create ~name:"notfound-test" ~tools:[] () in
367
+
let test_mcp_tool_not_found () =
368
+
let server = Claude.Mcp_server.v ~name:"notfound-test" ~tools:[] () in
383
369
let request =
384
370
J.object'
385
371
[
386
-
J.mem (J.name "jsonrpc") (J.string "2.0");
387
-
J.mem (J.name "id") (J.number 4.0);
388
-
J.mem (J.name "method") (J.string "tools/call");
389
-
J.mem (J.name "params")
390
-
(J.object' [ J.mem (J.name "name") (J.string "nonexistent") ]);
372
+
J.member (J.name "jsonrpc") (J.string "2.0");
373
+
J.member (J.name "id") (J.number 4.0);
374
+
J.member (J.name "method") (J.string "tools/call");
375
+
J.member (J.name "params")
376
+
(J.object' [ J.member (J.name "name") (J.string "nonexistent") ]);
391
377
]
392
378
in
393
379
let response = Claude.Mcp_server.handle_json_message server request in
394
380
(* Should return an error response *)
395
381
match response with
396
-
| Jsont.Object (mems, _) ->
382
+
| Json.Object (mems, _) ->
397
383
let has_error = List.exists (fun ((k, _), _) -> k = "error") mems in
398
384
Alcotest.(check bool) "has error" true has_error
399
385
| _ -> Alcotest.fail "Expected object response"
400
386
401
-
let test_mcp_server_method_not_found () =
402
-
let server =
403
-
Claude.Mcp_server.create ~name:"method-notfound-test" ~tools:[] ()
404
-
in
387
+
let test_mcp_method_not_found () =
388
+
let server = Claude.Mcp_server.v ~name:"method-notfound-test" ~tools:[] () in
405
389
let request =
406
390
J.object'
407
391
[
408
-
J.mem (J.name "jsonrpc") (J.string "2.0");
409
-
J.mem (J.name "id") (J.number 5.0);
410
-
J.mem (J.name "method") (J.string "unknown/method");
411
-
J.mem (J.name "params") (J.object' []);
392
+
J.member (J.name "jsonrpc") (J.string "2.0");
393
+
J.member (J.name "id") (J.number 5.0);
394
+
J.member (J.name "method") (J.string "unknown/method");
395
+
J.member (J.name "params") (J.object' []);
412
396
]
413
397
in
414
398
let response = Claude.Mcp_server.handle_json_message server request in
415
399
match response with
416
-
| Jsont.Object (mems, _) ->
400
+
| Json.Object (mems, _) ->
417
401
let has_error = List.exists (fun ((k, _), _) -> k = "error") mems in
418
402
Alcotest.(check bool) "has error" true has_error
419
403
| _ -> Alcotest.fail "Expected object response"
···
424
408
Alcotest.test_case "initialize" `Quick test_mcp_server_initialize;
425
409
Alcotest.test_case "tools/list" `Quick test_mcp_server_tools_list;
426
410
Alcotest.test_case "tools/call" `Quick test_mcp_server_tools_call;
427
-
Alcotest.test_case "tool not found" `Quick test_mcp_server_tool_not_found;
428
-
Alcotest.test_case "method not found" `Quick
429
-
test_mcp_server_method_not_found;
411
+
Alcotest.test_case "tool not found" `Quick test_mcp_tool_not_found;
412
+
Alcotest.test_case "method not found" `Quick test_mcp_method_not_found;
430
413
]
431
414
432
415
(* ============================================
···
435
418
436
419
let test_error_detail_creation () =
437
420
let error =
438
-
Claude.Proto.Control.Response.error_detail ~code:`Method_not_found
421
+
Claude.Control.Response.error_detail ~code:`Method_not_found
439
422
~message:"Method not found" ()
440
423
in
441
424
Alcotest.(check int) "error code" (-32601) error.code;
···
454
437
in
455
438
List.iter
456
439
(fun (code, expected_int) ->
457
-
let err =
458
-
Claude.Proto.Control.Response.error_detail ~code ~message:"test" ()
459
-
in
440
+
let err = Claude.Control.Response.error_detail ~code ~message:"test" () in
460
441
Alcotest.(check int) "error code value" expected_int err.code)
461
442
codes
462
443
463
444
let test_error_response_encoding () =
464
445
let error_detail =
465
-
Claude.Proto.Control.Response.error_detail ~code:`Invalid_params
446
+
Claude.Control.Response.error_detail ~code:`Invalid_params
466
447
~message:"Invalid parameters" ()
467
448
in
468
449
let error_resp =
469
-
Claude.Proto.Control.Response.error ~request_id:"test-123"
470
-
~error:error_detail ()
450
+
Claude.Control.Response.error ~request_id:"test-123" ~error:error_detail ()
471
451
in
472
-
match Jsont.Json.encode Claude.Proto.Control.Response.jsont error_resp with
473
-
| Ok json -> (
474
-
match Jsont.Json.decode Claude.Proto.Control.Response.jsont json with
475
-
| Ok (Claude.Proto.Control.Response.Error decoded) ->
476
-
Alcotest.(check string) "request_id" "test-123" decoded.request_id;
477
-
Alcotest.(check int) "error code" (-32602) decoded.error.code;
478
-
Alcotest.(check string)
479
-
"error message" "Invalid parameters" decoded.error.message
480
-
| Ok _ -> Alcotest.fail "Wrong response type decoded"
481
-
| Error e -> Alcotest.fail e)
482
-
| Error e -> Alcotest.fail e
452
+
let json = Json.encode Claude.Control.Response.json error_resp in
453
+
match Json.decode Claude.Control.Response.json json with
454
+
| Ok (Claude.Control.Response.Error decoded) ->
455
+
Alcotest.(check string) "request_id" "test-123" decoded.request_id;
456
+
Alcotest.(check int) "error code" (-32602) decoded.error.code;
457
+
Alcotest.(check string)
458
+
"error message" "Invalid parameters" decoded.error.message
459
+
| Ok _ -> Alcotest.fail "Wrong response type decoded"
460
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
483
461
484
462
let structured_error_tests =
485
463
[
···
494
472
Tool_input Tests
495
473
============================================ *)
496
474
497
-
let test_tool_input_get_string () =
498
-
let json = J.object' [ J.mem (J.name "foo") (J.string "bar") ] in
475
+
let test_tool_input_string () =
476
+
let json = J.object' [ J.member (J.name "foo") (J.string "bar") ] in
499
477
let input = Claude.Tool_input.of_json json in
500
478
Alcotest.(check (option string))
501
-
"get_string foo" (Some "bar")
502
-
(Claude.Tool_input.get_string input "foo");
479
+
"string foo" (Some "bar")
480
+
(Claude.Tool_input.string input "foo");
503
481
Alcotest.(check (option string))
504
-
"get_string missing" None
505
-
(Claude.Tool_input.get_string input "missing")
482
+
"string missing" None
483
+
(Claude.Tool_input.string input "missing")
506
484
507
-
let test_tool_input_get_int () =
508
-
let json = J.object' [ J.mem (J.name "count") (J.number 42.0) ] in
485
+
let test_tool_input_int () =
486
+
let json = J.object' [ J.member (J.name "count") (J.number 42.0) ] in
509
487
let input = Claude.Tool_input.of_json json in
510
488
Alcotest.(check (option int))
511
-
"get_int count" (Some 42)
512
-
(Claude.Tool_input.get_int input "count")
489
+
"int count" (Some 42)
490
+
(Claude.Tool_input.int input "count")
513
491
514
-
let test_tool_input_get_float () =
515
-
let json = J.object' [ J.mem (J.name "pi") (J.number 3.14159) ] in
492
+
let test_tool_input_float () =
493
+
let json = J.object' [ J.member (J.name "pi") (J.number 3.14159) ] in
516
494
let input = Claude.Tool_input.of_json json in
517
-
match Claude.Tool_input.get_float input "pi" with
495
+
match Claude.Tool_input.float input "pi" with
518
496
| Some f ->
519
497
Alcotest.(check bool)
520
-
"get_float pi approx" true
498
+
"float pi approx" true
521
499
(abs_float (f -. 3.14159) < 0.0001)
522
500
| None -> Alcotest.fail "Expected float"
523
501
524
-
let test_tool_input_get_bool () =
502
+
let test_tool_input_bool () =
525
503
let json =
526
504
J.object'
527
-
[ J.mem (J.name "yes") (J.bool true); J.mem (J.name "no") (J.bool false) ]
505
+
[
506
+
J.member (J.name "yes") (J.bool true);
507
+
J.member (J.name "no") (J.bool false);
508
+
]
528
509
in
529
510
let input = Claude.Tool_input.of_json json in
530
511
Alcotest.(check (option bool))
531
-
"get_bool yes" (Some true)
532
-
(Claude.Tool_input.get_bool input "yes");
512
+
"bool yes" (Some true)
513
+
(Claude.Tool_input.bool input "yes");
533
514
Alcotest.(check (option bool))
534
-
"get_bool no" (Some false)
535
-
(Claude.Tool_input.get_bool input "no")
515
+
"bool no" (Some false)
516
+
(Claude.Tool_input.bool input "no")
536
517
537
-
let test_tool_input_get_string_list () =
518
+
let test_tool_input_string_list () =
538
519
let json =
539
520
J.object'
540
521
[
541
-
J.mem (J.name "items")
522
+
J.member (J.name "items")
542
523
(J.list [ J.string "a"; J.string "b"; J.string "c" ]);
543
524
]
544
525
in
545
526
let input = Claude.Tool_input.of_json json in
546
527
Alcotest.(check (option (list string)))
547
-
"get_string_list"
528
+
"string_list"
548
529
(Some [ "a"; "b"; "c" ])
549
-
(Claude.Tool_input.get_string_list input "items")
530
+
(Claude.Tool_input.string_list input "items")
550
531
551
532
let tool_input_tests =
552
533
[
553
-
Alcotest.test_case "get_string" `Quick test_tool_input_get_string;
554
-
Alcotest.test_case "get_int" `Quick test_tool_input_get_int;
555
-
Alcotest.test_case "get_float" `Quick test_tool_input_get_float;
556
-
Alcotest.test_case "get_bool" `Quick test_tool_input_get_bool;
557
-
Alcotest.test_case "get_string_list" `Quick test_tool_input_get_string_list;
534
+
Alcotest.test_case "string" `Quick test_tool_input_string;
535
+
Alcotest.test_case "int" `Quick test_tool_input_int;
536
+
Alcotest.test_case "float" `Quick test_tool_input_float;
537
+
Alcotest.test_case "bool" `Quick test_tool_input_bool;
538
+
Alcotest.test_case "string_list" `Quick test_tool_input_string_list;
558
539
]
559
540
560
541
(* ============================================
561
542
Main test runner
562
543
============================================ *)
563
544
564
-
let () =
565
-
Alcotest.run "Claude SDK"
566
-
[
567
-
("Protocol", protocol_tests);
568
-
("Tool", tool_tests);
569
-
("Mcp_server", mcp_server_tests);
570
-
("Structured errors", structured_error_tests);
571
-
("Tool_input", tool_input_tests);
572
-
]
545
+
let suite =
546
+
( "claude",
547
+
protocol_tests @ tool_tests @ mcp_server_tests @ structured_error_tests
548
+
@ 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
+119
test/test_content_block.ml
+119
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 = Json.Value.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
+
let json = Json.encode CB.json block in
66
+
match Json.decode CB.json json with
67
+
| Ok back -> back
68
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
69
+
70
+
let test_jsont_roundtrip_text () =
71
+
let block = CB.text "roundtrip test" in
72
+
match json_roundtrip block with
73
+
| CB.Text t ->
74
+
Alcotest.(check string) "text" "roundtrip test" (CB.Text.text t)
75
+
| _ -> Alcotest.fail "Expected Text after roundtrip"
76
+
77
+
let test_jsont_roundtrip_tool_use () =
78
+
let input = Claude.Tool_input.empty |> Claude.Tool_input.add_string "f" "v" in
79
+
let block = CB.tool_use ~id:"id-1" ~name:"MyTool" ~input in
80
+
match json_roundtrip block with
81
+
| CB.Tool_use tu ->
82
+
Alcotest.(check string) "id" "id-1" (CB.Tool_use.id tu);
83
+
Alcotest.(check string) "name" "MyTool" (CB.Tool_use.name tu)
84
+
| _ -> Alcotest.fail "Expected Tool_use after roundtrip"
85
+
86
+
let test_jsont_roundtrip_thinking () =
87
+
let block = CB.thinking ~thinking:"hmm" ~signature:"s" in
88
+
match json_roundtrip block with
89
+
| CB.Thinking t ->
90
+
Alcotest.(check string) "thinking" "hmm" (CB.Thinking.thinking t);
91
+
Alcotest.(check string) "signature" "s" (CB.Thinking.signature t)
92
+
| _ -> Alcotest.fail "Expected Thinking after roundtrip"
93
+
94
+
let test_pp_does_not_crash () =
95
+
let block = CB.text "pp test" in
96
+
let buf = Buffer.create 64 in
97
+
let ppf = Format.formatter_of_buffer buf in
98
+
CB.pp ppf block;
99
+
Format.pp_print_flush ppf ();
100
+
Alcotest.(check bool) "pp output" true (Buffer.contents buf <> "")
101
+
102
+
let suite =
103
+
( "content_block",
104
+
[
105
+
Alcotest.test_case "text block" `Quick test_text_block;
106
+
Alcotest.test_case "tool_use block" `Quick test_tool_use_block;
107
+
Alcotest.test_case "tool_result block" `Quick test_tool_result_block;
108
+
Alcotest.test_case "tool_result with error" `Quick
109
+
test_tool_result_with_error;
110
+
Alcotest.test_case "tool_result no content" `Quick
111
+
test_tool_result_no_content;
112
+
Alcotest.test_case "thinking block" `Quick test_thinking_block;
113
+
Alcotest.test_case "json roundtrip text" `Quick test_jsont_roundtrip_text;
114
+
Alcotest.test_case "json roundtrip tool_use" `Quick
115
+
test_jsont_roundtrip_tool_use;
116
+
Alcotest.test_case "json roundtrip thinking" `Quick
117
+
test_jsont_roundtrip_thinking;
118
+
Alcotest.test_case "pp does not crash" `Quick test_pp_does_not_crash;
119
+
] )
+2
test/test_content_block.mli
+2
test/test_content_block.mli
+292
test/test_control.ml
+292
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 = Json.Value.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
+
let json = Json.encode C.Request.json req in
92
+
match Json.decode C.Request.json json with
93
+
| Ok (C.Request.Interrupt _) -> ()
94
+
| Ok _ -> Alcotest.fail "Wrong variant"
95
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
96
+
97
+
let test_request_jsont_permission () =
98
+
let input =
99
+
Json.Value.object'
100
+
[ Json.Value.member (Json.Value.name "cmd") (Json.Value.string "ls") ]
101
+
in
102
+
let req = C.Request.permission ~tool_name:"Bash" ~input () in
103
+
let json = Json.encode C.Request.json req in
104
+
match Json.decode C.Request.json json with
105
+
| Ok (C.Request.Permission p) ->
106
+
Alcotest.(check string) "tool_name" "Bash" p.tool_name
107
+
| Ok _ -> Alcotest.fail "Wrong variant"
108
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
109
+
110
+
let test_request_jsont_set_model () =
111
+
let req = C.Request.set_model ~model:"claude-haiku-4" () in
112
+
let json = Json.encode C.Request.json req in
113
+
match Json.decode C.Request.json json with
114
+
| Ok (C.Request.Set_model sm) ->
115
+
Alcotest.(check string) "model" "claude-haiku-4" sm.model
116
+
| Ok _ -> Alcotest.fail "Wrong variant"
117
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
118
+
119
+
let test_request_jsont_get_server_info () =
120
+
let req = C.Request.get_server_info () in
121
+
let json = Json.encode C.Request.json req in
122
+
match Json.decode C.Request.json json with
123
+
| Ok (C.Request.Get_server_info _) -> ()
124
+
| Ok _ -> Alcotest.fail "Wrong variant"
125
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
126
+
127
+
let test_request_jsont_hook_callback () =
128
+
let input = Json.Value.object' [] in
129
+
let req = C.Request.hook_callback ~callback_id:"cb-1" ~input () in
130
+
let json = Json.encode C.Request.json req in
131
+
match Json.decode C.Request.json json with
132
+
| Ok (C.Request.Hook_callback hc) ->
133
+
Alcotest.(check string) "callback_id" "cb-1" hc.callback_id
134
+
| Ok _ -> Alcotest.fail "Wrong variant"
135
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
136
+
137
+
let test_request_jsont_mcp_message () =
138
+
let message = Json.Value.object' [] in
139
+
let req = C.Request.mcp_message ~server_name:"tools" ~message () in
140
+
let json = Json.encode C.Request.json req in
141
+
match Json.decode C.Request.json json with
142
+
| Ok (C.Request.Mcp_message mm) ->
143
+
Alcotest.(check string) "server_name" "tools" mm.server_name
144
+
| Ok _ -> Alcotest.fail "Wrong variant"
145
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
146
+
147
+
let test_response_jsont_success () =
148
+
let resp = C.Response.success ~request_id:"r1" () in
149
+
let json = Json.encode C.Response.json resp in
150
+
match Json.decode C.Response.json json with
151
+
| Ok (C.Response.Success s) ->
152
+
Alcotest.(check string) "request_id" "r1" s.request_id
153
+
| Ok _ -> Alcotest.fail "Wrong variant"
154
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
155
+
156
+
let test_response_success_data () =
157
+
let data = Json.Value.string "result_data" in
158
+
let resp = C.Response.success ~request_id:"r2" ~response:data () in
159
+
let json = Json.encode C.Response.json resp in
160
+
match Json.decode C.Response.json json with
161
+
| Ok (C.Response.Success s) ->
162
+
Alcotest.(check bool) "has response" true (Option.is_some s.response)
163
+
| Ok _ -> Alcotest.fail "Wrong variant"
164
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
165
+
166
+
let test_response_jsont_error () =
167
+
let detail =
168
+
C.Response.error_detail ~code:`Internal_error ~message:"oops" ()
169
+
in
170
+
let resp = C.Response.error ~request_id:"r3" ~error:detail () in
171
+
let json = Json.encode C.Response.json resp in
172
+
match Json.decode C.Response.json json with
173
+
| Ok (C.Response.Error e) ->
174
+
Alcotest.(check string) "request_id" "r3" e.request_id;
175
+
Alcotest.(check int) "code" (-32603) e.error.code;
176
+
Alcotest.(check string) "message" "oops" e.error.message
177
+
| Ok _ -> Alcotest.fail "Wrong variant"
178
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
179
+
180
+
let test_server_info () =
181
+
let info =
182
+
C.Server_info.create ~version:"2.0.0"
183
+
~capabilities:[ "hooks"; "structured-output" ]
184
+
~commands:[ "run" ] ~output_styles:[ "json" ] ()
185
+
in
186
+
Alcotest.(check string) "version" "2.0.0" (C.Server_info.version info);
187
+
Alcotest.(check (list string))
188
+
"capabilities"
189
+
[ "hooks"; "structured-output" ]
190
+
(C.Server_info.capabilities info)
191
+
192
+
let test_server_info_jsont_roundtrip () =
193
+
let info =
194
+
C.Server_info.create ~version:"1.0.0" ~capabilities:[ "mcp" ] ~commands:[]
195
+
~output_styles:[] ()
196
+
in
197
+
let json = Json.encode C.Server_info.json info in
198
+
match Json.decode C.Server_info.json json with
199
+
| Ok back ->
200
+
Alcotest.(check string) "version" "1.0.0" (C.Server_info.version back)
201
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
202
+
203
+
let test_request_envelope () =
204
+
let req = C.Request.interrupt () in
205
+
match C.request ~request_id:"env-1" ~request:req () with
206
+
| C.Request env -> Alcotest.(check string) "request_id" "env-1" env.request_id
207
+
| _ -> Alcotest.fail "Expected Request envelope"
208
+
209
+
let test_response_envelope () =
210
+
let resp = C.Response.success ~request_id:"x" () in
211
+
match C.response ~response:resp () with
212
+
| C.Response env -> (
213
+
match env.response with
214
+
| C.Response.Success _ -> ()
215
+
| _ -> Alcotest.fail "Expected success response")
216
+
| _ -> Alcotest.fail "Expected Response envelope"
217
+
218
+
let test_request_envelope_jsont () =
219
+
let req = C.Request.interrupt () in
220
+
let env : C.control_request =
221
+
{
222
+
type_ = `Control_request;
223
+
request_id = "env-1";
224
+
request = req;
225
+
unknown = Claude.Unknown.empty;
226
+
}
227
+
in
228
+
let json = Json.encode C.control_request_jsont env in
229
+
match Json.decode C.control_request_jsont json with
230
+
| Ok back -> Alcotest.(check string) "request_id" "env-1" back.request_id
231
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
232
+
233
+
let test_response_envelope_jsont () =
234
+
let resp = C.Response.success ~request_id:"x" () in
235
+
let env : C.control_response =
236
+
{
237
+
type_ = `Control_response;
238
+
response = resp;
239
+
unknown = Claude.Unknown.empty;
240
+
}
241
+
in
242
+
let json = Json.encode C.control_response_jsont env in
243
+
match Json.decode C.control_response_jsont json with
244
+
| Ok back -> (
245
+
match back.response with
246
+
| C.Response.Success _ -> ()
247
+
| _ -> Alcotest.fail "Wrong variant")
248
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
249
+
250
+
let suite =
251
+
( "control",
252
+
[
253
+
Alcotest.test_case "interrupt request" `Quick test_interrupt_request;
254
+
Alcotest.test_case "permission request" `Quick test_permission_request;
255
+
Alcotest.test_case "initialize request" `Quick test_initialize_request;
256
+
Alcotest.test_case "set_permission_mode request" `Quick
257
+
test_set_permission_mode_request;
258
+
Alcotest.test_case "set_model request" `Quick test_set_model_request;
259
+
Alcotest.test_case "get_server_info request" `Quick
260
+
test_get_server_info_request;
261
+
Alcotest.test_case "success response" `Quick test_success_response;
262
+
Alcotest.test_case "error response" `Quick test_error_response;
263
+
Alcotest.test_case "error codes" `Quick test_error_codes;
264
+
Alcotest.test_case "error code of_int roundtrip" `Quick
265
+
test_error_code_of_int;
266
+
Alcotest.test_case "request json interrupt" `Quick
267
+
test_request_jsont_interrupt;
268
+
Alcotest.test_case "request json permission" `Quick
269
+
test_request_jsont_permission;
270
+
Alcotest.test_case "request json set_model" `Quick
271
+
test_request_jsont_set_model;
272
+
Alcotest.test_case "request json get_server_info" `Quick
273
+
test_request_jsont_get_server_info;
274
+
Alcotest.test_case "request json hook_callback" `Quick
275
+
test_request_jsont_hook_callback;
276
+
Alcotest.test_case "request json mcp_message" `Quick
277
+
test_request_jsont_mcp_message;
278
+
Alcotest.test_case "response json success" `Quick
279
+
test_response_jsont_success;
280
+
Alcotest.test_case "response json success with data" `Quick
281
+
test_response_success_data;
282
+
Alcotest.test_case "response json error" `Quick test_response_jsont_error;
283
+
Alcotest.test_case "server_info" `Quick test_server_info;
284
+
Alcotest.test_case "server_info json roundtrip" `Quick
285
+
test_server_info_jsont_roundtrip;
286
+
Alcotest.test_case "request envelope" `Quick test_request_envelope;
287
+
Alcotest.test_case "response envelope" `Quick test_response_envelope;
288
+
Alcotest.test_case "request envelope json" `Quick
289
+
test_request_envelope_jsont;
290
+
Alcotest.test_case "response envelope json" `Quick
291
+
test_response_envelope_jsont;
292
+
] )
+2
test/test_control.mli
+2
test/test_control.mli
+180
test/test_error.ml
+180
test/test_error.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Error module: error formatting, raisers, and result helpers. *)
7
+
8
+
let test_cli_not_found_format () =
9
+
let err = Claude.Error.Cli_not_found "claude not in PATH" in
10
+
Alcotest.(check string)
11
+
"format" "CLI not found: claude not in PATH"
12
+
(Claude.Error.to_string err)
13
+
14
+
let test_process_error_format () =
15
+
let err = Claude.Error.Process_error "exit code 1" in
16
+
Alcotest.(check string)
17
+
"format" "Process error: exit code 1"
18
+
(Claude.Error.to_string err)
19
+
20
+
let test_connection_error_format () =
21
+
let err = Claude.Error.Connection_error "refused" in
22
+
Alcotest.(check string)
23
+
"format" "Connection error: refused"
24
+
(Claude.Error.to_string err)
25
+
26
+
let test_protocol_error_format () =
27
+
let err = Claude.Error.Protocol_error "bad json" in
28
+
Alcotest.(check string)
29
+
"format" "Protocol error: bad json"
30
+
(Claude.Error.to_string err)
31
+
32
+
let test_timeout_format () =
33
+
let err = Claude.Error.Timeout "30s elapsed" in
34
+
Alcotest.(check string)
35
+
"format" "Timeout: 30s elapsed"
36
+
(Claude.Error.to_string err)
37
+
38
+
let test_permission_denied_format () =
39
+
let err =
40
+
Claude.Error.Permission_denied
41
+
{ tool_name = "Bash"; message = "not allowed" }
42
+
in
43
+
Alcotest.(check string)
44
+
"format" "Permission denied for tool 'Bash': not allowed"
45
+
(Claude.Error.to_string err)
46
+
47
+
let test_hook_error_format () =
48
+
let err =
49
+
Claude.Error.Hook_error { callback_id = "cb-1"; message = "hook failed" }
50
+
in
51
+
Alcotest.(check string)
52
+
"format" "Hook error (callback_id=cb-1): hook failed"
53
+
(Claude.Error.to_string err)
54
+
55
+
let test_control_error_format () =
56
+
let err =
57
+
Claude.Error.Control_error { request_id = "req-42"; message = "invalid" }
58
+
in
59
+
Alcotest.(check string)
60
+
"format" "Control error (request_id=req-42): invalid"
61
+
(Claude.Error.to_string err)
62
+
63
+
let test_raise_cli_not_found () =
64
+
match Claude.Error.cli_not_found "missing" with
65
+
| exception Claude.Error.E (Claude.Error.Cli_not_found "missing") -> ()
66
+
| exception _ -> Alcotest.fail "Wrong exception type"
67
+
| _ -> Alcotest.fail "Expected exception"
68
+
69
+
let test_raise_process_error () =
70
+
match Claude.Error.process_error "crash" with
71
+
| exception Claude.Error.E (Claude.Error.Process_error "crash") -> ()
72
+
| exception _ -> Alcotest.fail "Wrong exception type"
73
+
| _ -> Alcotest.fail "Expected exception"
74
+
75
+
let test_raise_connection_error () =
76
+
match Claude.Error.connection_error "reset" with
77
+
| exception Claude.Error.E (Claude.Error.Connection_error "reset") -> ()
78
+
| exception _ -> Alcotest.fail "Wrong exception type"
79
+
| _ -> Alcotest.fail "Expected exception"
80
+
81
+
let test_raise_protocol_error () =
82
+
match Claude.Error.protocol_error "malformed" with
83
+
| exception Claude.Error.E (Claude.Error.Protocol_error "malformed") -> ()
84
+
| exception _ -> Alcotest.fail "Wrong exception type"
85
+
| _ -> Alcotest.fail "Expected exception"
86
+
87
+
let test_raise_timeout () =
88
+
match Claude.Error.timeout "expired" with
89
+
| exception Claude.Error.E (Claude.Error.Timeout "expired") -> ()
90
+
| exception _ -> Alcotest.fail "Wrong exception type"
91
+
| _ -> Alcotest.fail "Expected exception"
92
+
93
+
let test_raise_permission_denied () =
94
+
match Claude.Error.permission_denied ~tool_name:"Edit" ~message:"blocked" with
95
+
| exception
96
+
Claude.Error.E
97
+
(Claude.Error.Permission_denied
98
+
{ tool_name = "Edit"; message = "blocked" }) ->
99
+
()
100
+
| exception _ -> Alcotest.fail "Wrong exception type"
101
+
| _ -> Alcotest.fail "Expected exception"
102
+
103
+
let test_raise_hook_error () =
104
+
match Claude.Error.hook_error ~callback_id:"cb-x" ~message:"fail" with
105
+
| exception
106
+
Claude.Error.E
107
+
(Claude.Error.Hook_error { callback_id = "cb-x"; message = "fail" }) ->
108
+
()
109
+
| exception _ -> Alcotest.fail "Wrong exception type"
110
+
| _ -> Alcotest.fail "Expected exception"
111
+
112
+
let test_raise_control_error () =
113
+
match Claude.Error.control_error ~request_id:"req-1" ~message:"bad" with
114
+
| exception
115
+
Claude.Error.E
116
+
(Claude.Error.Control_error { request_id = "req-1"; message = "bad" })
117
+
->
118
+
()
119
+
| exception _ -> Alcotest.fail "Wrong exception type"
120
+
| _ -> Alcotest.fail "Expected exception"
121
+
122
+
let test_ok_success () =
123
+
let v = Claude.Error.ok ~msg:"test: " (Ok 42) in
124
+
Alcotest.(check int) "ok value" 42 v
125
+
126
+
let test_ok_error () =
127
+
match Claude.Error.ok ~msg:"prefix: " (Error "reason") with
128
+
| exception Claude.Error.E (Claude.Error.Protocol_error msg) ->
129
+
Alcotest.(check bool) "contains prefix" true (String.length msg > 0)
130
+
| exception _ -> Alcotest.fail "Wrong exception type"
131
+
| _ -> Alcotest.fail "Expected exception"
132
+
133
+
let test_ok'_success () =
134
+
let v = Claude.Error.ok' ~msg:"test: " (Ok "hello") in
135
+
Alcotest.(check string) "ok' value" "hello" v
136
+
137
+
let test_ok'_error () =
138
+
match Claude.Error.ok' ~msg:"prefix: " (Error "reason") with
139
+
| exception Claude.Error.E (Claude.Error.Protocol_error _) -> ()
140
+
| exception _ -> Alcotest.fail "Wrong exception type"
141
+
| _ -> Alcotest.fail "Expected exception"
142
+
143
+
let test_pp_output () =
144
+
let err = Claude.Error.Timeout "10s" in
145
+
let buf = Buffer.create 32 in
146
+
let ppf = Format.formatter_of_buffer buf in
147
+
Claude.Error.pp ppf err;
148
+
Format.pp_print_flush ppf ();
149
+
Alcotest.(check string) "pp output" "Timeout: 10s" (Buffer.contents buf)
150
+
151
+
let suite =
152
+
( "err",
153
+
[
154
+
Alcotest.test_case "Cli_not_found format" `Quick test_cli_not_found_format;
155
+
Alcotest.test_case "Process_error format" `Quick test_process_error_format;
156
+
Alcotest.test_case "Connection_error format" `Quick
157
+
test_connection_error_format;
158
+
Alcotest.test_case "Protocol_error format" `Quick
159
+
test_protocol_error_format;
160
+
Alcotest.test_case "Timeout format" `Quick test_timeout_format;
161
+
Alcotest.test_case "Permission_denied format" `Quick
162
+
test_permission_denied_format;
163
+
Alcotest.test_case "Hook_error format" `Quick test_hook_error_format;
164
+
Alcotest.test_case "Control_error format" `Quick test_control_error_format;
165
+
Alcotest.test_case "raise cli_not_found" `Quick test_raise_cli_not_found;
166
+
Alcotest.test_case "raise process_error" `Quick test_raise_process_error;
167
+
Alcotest.test_case "raise connection_error" `Quick
168
+
test_raise_connection_error;
169
+
Alcotest.test_case "raise protocol_error" `Quick test_raise_protocol_error;
170
+
Alcotest.test_case "raise timeout" `Quick test_raise_timeout;
171
+
Alcotest.test_case "raise permission_denied" `Quick
172
+
test_raise_permission_denied;
173
+
Alcotest.test_case "raise hook_error" `Quick test_raise_hook_error;
174
+
Alcotest.test_case "raise control_error" `Quick test_raise_control_error;
175
+
Alcotest.test_case "ok success" `Quick test_ok_success;
176
+
Alcotest.test_case "ok error" `Quick test_ok_error;
177
+
Alcotest.test_case "ok' success" `Quick test_ok'_success;
178
+
Alcotest.test_case "ok' error" `Quick test_ok'_error;
179
+
Alcotest.test_case "pp output" `Quick test_pp_output;
180
+
] )
+2
test/test_error.mli
+2
test/test_error.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
+97
-75
test/test_incoming.ml
+97
-75
test/test_incoming.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** Test the Incoming message codec *)
6
+
let decode_incoming json_str = Json.of_string Claude.Incoming.json json_str
7
7
8
-
let test_decode_user_message () =
9
-
let json_str = {|{"type":"user","content":"Hello"}|} in
10
-
match Jsont_bytesrw.decode_string' Proto.Incoming.jsont json_str with
11
-
| Ok (Proto.Incoming.Message (Proto.Message.User _)) ->
12
-
print_endline "✓ Decoded user message successfully"
13
-
| Ok _ -> print_endline "✗ Wrong message type decoded"
14
-
| Error err ->
15
-
Printf.printf "✗ Failed to decode user message: %s\n"
16
-
(Jsont.Error.to_string err)
8
+
let test_decode_system_init () =
9
+
let json =
10
+
{|{"type":"system","subtype":"init","session_id":"s1","model":"claude-sonnet-4","cwd":"/tmp"}|}
11
+
in
12
+
match decode_incoming json with
13
+
| Ok (Claude.Incoming.Message (Claude.Message.System sys)) ->
14
+
Alcotest.(check (option string))
15
+
"session_id" (Some "s1")
16
+
(Claude.Message.System.session_id sys);
17
+
Alcotest.(check (option string))
18
+
"model" (Some "claude-sonnet-4")
19
+
(Claude.Message.System.model sys);
20
+
Alcotest.(check (option string))
21
+
"cwd" (Some "/tmp")
22
+
(Claude.Message.System.cwd sys)
23
+
| Ok _ -> Alcotest.fail "Wrong message type"
24
+
| Error err -> Alcotest.fail (Json.Error.to_string err)
17
25
18
-
let test_decode_assistant_message () =
19
-
let json_str =
20
-
{|{"type":"assistant","model":"claude-sonnet-4","content":[{"type":"text","text":"Hi"}]}|}
26
+
let test_decode_system_error () =
27
+
let json =
28
+
{|{"type":"system","subtype":"error","error":"something went wrong"}|}
21
29
in
22
-
match Jsont_bytesrw.decode_string' Proto.Incoming.jsont json_str with
23
-
| Ok (Proto.Incoming.Message (Proto.Message.Assistant _)) ->
24
-
print_endline "✓ Decoded assistant message successfully"
25
-
| Ok _ -> print_endline "✗ Wrong message type decoded"
26
-
| Error err ->
27
-
Printf.printf "✗ Failed to decode assistant message: %s\n"
28
-
(Jsont.Error.to_string err)
30
+
match decode_incoming json with
31
+
| Ok
32
+
(Claude.Incoming.Message
33
+
(Claude.Message.System (Claude.Message.System.Error e))) ->
34
+
Alcotest.(check string) "error" "something went wrong" e.error
35
+
| Ok _ -> Alcotest.fail "Wrong message type"
36
+
| Error err -> Alcotest.fail (Json.Error.to_string err)
29
37
30
-
let test_decode_system_message () =
31
-
let json_str =
32
-
{|{"type":"system","subtype":"init","data":{"session_id":"test-123"}}|}
38
+
let test_decode_result () =
39
+
let json =
40
+
{|{"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}|}
33
41
in
34
-
match Jsont_bytesrw.decode_string' Proto.Incoming.jsont json_str with
35
-
| Ok (Proto.Incoming.Message (Proto.Message.System _)) ->
36
-
print_endline "✓ Decoded system message successfully"
37
-
| Ok _ -> print_endline "✗ Wrong message type decoded"
38
-
| Error err ->
39
-
Printf.printf "✗ Failed to decode system message: %s\n"
40
-
(Jsont.Error.to_string err)
42
+
match decode_incoming json with
43
+
| Ok (Claude.Incoming.Message (Claude.Message.Result r)) ->
44
+
Alcotest.(check int)
45
+
"duration_ms" 1000
46
+
(Claude.Message.Result.duration_ms r);
47
+
Alcotest.(check int) "num_turns" 3 (Claude.Message.Result.num_turns r);
48
+
Alcotest.(check string)
49
+
"session_id" "sess-42"
50
+
(Claude.Message.Result.session_id r);
51
+
Alcotest.(check bool)
52
+
"not is_error" false
53
+
(Claude.Message.Result.is_error r)
54
+
| Ok _ -> Alcotest.fail "Wrong message type"
55
+
| Error err -> Alcotest.fail (Json.Error.to_string err)
41
56
42
-
let test_decode_control_response () =
43
-
let json_str =
44
-
{|{"type":"control_response","response":{"subtype":"success","requestId":"test-req-1"}}|}
57
+
let test_decode_assistant_tools () =
58
+
let json =
59
+
{|{"type":"assistant","message":{"model":"claude-sonnet-4","content":[{"type":"tool_use","id":"tu-1","name":"Bash","input":{"command":"ls"}}]}}|}
45
60
in
46
-
match Jsont_bytesrw.decode_string' Proto.Incoming.jsont json_str with
47
-
| Ok (Proto.Incoming.Control_response resp) -> (
48
-
match resp.response with
49
-
| Proto.Control.Response.Success s ->
50
-
if s.request_id = "test-req-1" then
51
-
print_endline "✓ Decoded control response successfully"
52
-
else Printf.printf "✗ Wrong request_id: %s\n" s.request_id
53
-
| Proto.Control.Response.Error _ ->
54
-
print_endline "✗ Got error response instead of success")
55
-
| Ok _ -> print_endline "✗ Wrong message type decoded"
56
-
| Error err ->
57
-
Printf.printf "✗ Failed to decode control response: %s\n"
58
-
(Jsont.Error.to_string err)
61
+
match decode_incoming json with
62
+
| Ok (Claude.Incoming.Message (Claude.Message.Assistant msg)) ->
63
+
let content = Claude.Message.Assistant.content msg in
64
+
let has_tool_use =
65
+
List.exists
66
+
(function Claude.Content_block.Tool_use _ -> true | _ -> false)
67
+
content
68
+
in
69
+
Alcotest.(check bool) "has_tool_use" true has_tool_use
70
+
| Ok _ -> Alcotest.fail "Wrong message type"
71
+
| Error err -> Alcotest.fail (Json.Error.to_string err)
59
72
60
-
let test_decode_control_response_error () =
61
-
let json_str =
62
-
{|{"type":"control_response","response":{"subtype":"error","requestId":"test-req-2","error":{"code":-32603,"message":"Something went wrong"}}}|}
73
+
let test_decode_control_response () =
74
+
let json =
75
+
{|{"type":"control_response","response":{"subtype":"success","request_id":"req-1"}}|}
63
76
in
64
-
match Jsont_bytesrw.decode_string' Proto.Incoming.jsont json_str with
65
-
| Ok (Proto.Incoming.Control_response resp) -> (
66
-
match resp.response with
67
-
| Proto.Control.Response.Error e ->
68
-
if
69
-
e.request_id = "test-req-2"
70
-
&& e.error.code = -32603
71
-
&& e.error.message = "Something went wrong"
72
-
then print_endline "✓ Decoded control error response successfully"
73
-
else Printf.printf "✗ Wrong error content\n"
74
-
| Proto.Control.Response.Success _ ->
75
-
print_endline "✗ Got success response instead of error")
76
-
| Ok _ -> print_endline "✗ Wrong message type decoded"
77
-
| Error err ->
78
-
Printf.printf "✗ Failed to decode control error response: %s\n"
79
-
(Jsont.Error.to_string err)
77
+
match decode_incoming json with
78
+
| Ok (Claude.Incoming.Control_response _) -> ()
79
+
| Ok _ -> Alcotest.fail "Wrong message type, expected Control_response"
80
+
| Error err -> Alcotest.fail (Json.Error.to_string err)
80
81
81
-
let () =
82
-
print_endline "Testing Incoming message codec...";
83
-
print_endline "";
84
-
test_decode_user_message ();
85
-
test_decode_assistant_message ();
86
-
test_decode_system_message ();
87
-
test_decode_control_response ();
88
-
test_decode_control_response_error ();
89
-
print_endline "";
90
-
print_endline "All tests completed!"
82
+
let test_decode_user_message () =
83
+
let json = {|{"type":"user","message":{"content":"Hi"}}|} in
84
+
match decode_incoming json with
85
+
| Ok (Claude.Incoming.Message (Claude.Message.User _)) -> ()
86
+
| Ok _ -> Alcotest.fail "Expected user message"
87
+
| Error err -> Alcotest.fail (Json.Error.to_string err)
88
+
89
+
let test_pp_does_not_crash () =
90
+
let json = {|{"type":"user","message":{"content":"Hi"}}|} in
91
+
match decode_incoming json with
92
+
| Ok incoming ->
93
+
let buf = Buffer.create 64 in
94
+
let ppf = Format.formatter_of_buffer buf in
95
+
Claude.Incoming.pp ppf incoming;
96
+
Format.pp_print_flush ppf ();
97
+
Alcotest.(check bool) "pp output" true (Buffer.contents buf <> "")
98
+
| Error err -> Alcotest.fail (Json.Error.to_string err)
99
+
100
+
let suite =
101
+
( "incoming",
102
+
[
103
+
Alcotest.test_case "decode system init" `Quick test_decode_system_init;
104
+
Alcotest.test_case "decode system error" `Quick test_decode_system_error;
105
+
Alcotest.test_case "decode result" `Quick test_decode_result;
106
+
Alcotest.test_case "decode assistant with tool_use" `Quick
107
+
test_decode_assistant_tools;
108
+
Alcotest.test_case "decode control_response" `Quick
109
+
test_decode_control_response;
110
+
Alcotest.test_case "decode user message" `Quick test_decode_user_message;
111
+
Alcotest.test_case "pp does not crash" `Quick test_pp_does_not_crash;
112
+
] )
+2
test/test_incoming.mli
+2
test/test_incoming.mli
+173
test/test_mcp_server.ml
+173
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 = Json.Value
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.member (J.name "jsonrpc") (J.string "2.0");
46
+
J.member (J.name "id") (J.number 1.0);
47
+
J.member (J.name "method") (J.string "initialize");
48
+
J.member (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
+
| Json.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.member (J.name "jsonrpc") (J.string "2.0");
65
+
J.member (J.name "id") (J.number 1.0);
66
+
J.member (J.name "method") (J.string "tools/list");
67
+
J.member (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
+
| Json.Object (mems, _) -> (
73
+
match List.find_opt (fun ((k, _), _) -> k = "result") mems with
74
+
| Some (_, Json.Object (result_mems, _)) -> (
75
+
match List.find_opt (fun ((k, _), _) -> k = "tools") result_mems with
76
+
| Some (_, Json.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.member (J.name "jsonrpc") (J.string "2.0");
101
+
J.member (J.name "id") (J.number 1.0);
102
+
J.member (J.name "method") (J.string "tools/call");
103
+
J.member (J.name "params")
104
+
(J.object'
105
+
[
106
+
J.member (J.name "name") (J.string "add");
107
+
J.member (J.name "arguments")
108
+
(J.object'
109
+
[
110
+
J.member (J.name "a") (J.number 3.0);
111
+
J.member (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 = Json.Value.to_string resp in
118
+
(* Check the response contains "10" *)
119
+
Alcotest.(check bool)
120
+
"contains 10" true
121
+
(let rec check i =
122
+
if i + 2 > String.length resp_str then false
123
+
else if String.sub resp_str i 2 = "10" then true
124
+
else check (i + 1)
125
+
in
126
+
check 0)
127
+
128
+
let test_handle_unknown_method () =
129
+
let server = Claude.Mcp_server.v ~name:"s" ~tools:[] () in
130
+
let req =
131
+
J.object'
132
+
[
133
+
J.member (J.name "jsonrpc") (J.string "2.0");
134
+
J.member (J.name "id") (J.number 1.0);
135
+
J.member (J.name "method") (J.string "completely/unknown");
136
+
J.member (J.name "params") (J.object' []);
137
+
]
138
+
in
139
+
let resp = Claude.Mcp_server.handle_json_message server req in
140
+
match resp with
141
+
| Json.Object (mems, _) ->
142
+
Alcotest.(check bool)
143
+
"has error" true
144
+
(List.exists (fun ((k, _), _) -> k = "error") mems)
145
+
| _ -> Alcotest.fail "Expected object"
146
+
147
+
let test_handle_request_directly () =
148
+
let tool = mk_tool "echo" in
149
+
let server = Claude.Mcp_server.v ~name:"s" ~tools:[ tool ] () in
150
+
let id = J.number 99.0 in
151
+
let resp =
152
+
Claude.Mcp_server.handle_request server ~method_:"tools/list"
153
+
~params:(J.object' []) ~id
154
+
in
155
+
match resp with Json.Object _ -> () | _ -> Alcotest.fail "Expected object"
156
+
157
+
let suite =
158
+
( "mcp_server",
159
+
[
160
+
Alcotest.test_case "default version" `Quick test_default_version;
161
+
Alcotest.test_case "custom version" `Quick test_custom_version;
162
+
Alcotest.test_case "name" `Quick test_name;
163
+
Alcotest.test_case "tools list accessor" `Quick test_tools_list;
164
+
Alcotest.test_case "handle initialize" `Quick test_handle_initialize;
165
+
Alcotest.test_case "handle tools/list empty" `Quick
166
+
test_handle_tools_list_empty;
167
+
Alcotest.test_case "handle tools/call success" `Quick
168
+
test_handle_tools_call_success;
169
+
Alcotest.test_case "handle unknown method" `Quick
170
+
test_handle_unknown_method;
171
+
Alcotest.test_case "handle_request directly" `Quick
172
+
test_handle_request_directly;
173
+
] )
+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 = Json.Value.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
+91
test/test_outgoing.ml
+91
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 Json.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 Json.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 Json.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
+
let json = Json.encode O.json msg in
45
+
match Json.decode O.json json with
46
+
| Ok (O.Message (M.User _)) -> ()
47
+
| Ok _ -> Alcotest.fail "Wrong variant after decode"
48
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
49
+
50
+
let test_jsont_roundtrip_control_response () =
51
+
let resp = C.Response.success ~request_id:"r2" () in
52
+
let envelope = mk_control_response resp in
53
+
let msg = O.Control_response envelope in
54
+
let json = Json.encode O.json msg in
55
+
match Json.decode O.json json with
56
+
| Ok (O.Control_response _) -> ()
57
+
| Ok _ -> Alcotest.fail "Wrong variant after decode"
58
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
59
+
60
+
let test_pp_does_not_crash () =
61
+
let user = M.User.of_string "pp test" in
62
+
let msg = O.Message (M.User user) in
63
+
let buf = Buffer.create 64 in
64
+
let ppf = Format.formatter_of_buffer buf in
65
+
O.pp ppf msg;
66
+
Format.pp_print_flush ppf ();
67
+
Alcotest.(check bool) "pp output" true (Buffer.contents buf <> "")
68
+
69
+
let test_of_json_user () =
70
+
let user = M.User.of_string "roundtrip" in
71
+
let msg = O.Message (M.User user) in
72
+
let json = O.to_json msg in
73
+
let back = O.of_json json in
74
+
match back with
75
+
| O.Message (M.User _) -> ()
76
+
| _ -> Alcotest.fail "Expected user message back"
77
+
78
+
let suite =
79
+
( "outgoing",
80
+
[
81
+
Alcotest.test_case "encode user message" `Quick test_encode_user_message;
82
+
Alcotest.test_case "encode control response" `Quick
83
+
test_encode_control_response;
84
+
Alcotest.test_case "encode control request" `Quick
85
+
test_encode_control_request;
86
+
Alcotest.test_case "json roundtrip user" `Quick test_jsont_roundtrip_user;
87
+
Alcotest.test_case "json roundtrip control response" `Quick
88
+
test_jsont_roundtrip_control_response;
89
+
Alcotest.test_case "pp does not crash" `Quick test_pp_does_not_crash;
90
+
Alcotest.test_case "of_json user" `Quick test_of_json_user;
91
+
] )
+2
test/test_outgoing.mli
+2
test/test_outgoing.mli
+160
-68
test/test_permissions.ml
+160
-68
test/test_permissions.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
open Eio.Std
6
+
(** Tests for Permissions module: Mode, Rule, Decision, callbacks. *)
7
7
8
-
let src = Logs.Src.create "test_permissions" ~doc:"Permission callback test"
8
+
module P = Claude.Permissions
9
9
10
-
module Log = (val Logs.src_log src : Logs.LOG)
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
11
24
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 ()
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
17
41
18
-
let run_test ~sw ~env =
19
-
Log.app (fun m -> m "🧪 Testing Permission Callbacks");
20
-
Log.app (fun m -> m "================================");
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"
21
46
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
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
+
]
27
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
28
63
29
-
Log.app (fun m -> m "Creating client with permission callback...");
30
-
let client =
31
-
Claude.Client.create ~options ~sw ~process_mgr:env#process_mgr
32
-
~clock:env#clock ()
33
-
in
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)
34
70
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.";
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)
38
76
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));
77
+
let test_rule_proto_roundtrip () =
78
+
let rule = P.Rule.create ~tool_name:"Read" ~rule_content:"*.txt" () in
79
+
let json = Json.encode P.Rule.json rule in
80
+
let back = Json.decode P.Rule.json 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)
42
84
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;
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)
59
96
60
-
Log.app (fun m -> m "\n================================");
61
-
Log.app (fun m -> m "✨ Test complete!")
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)
62
118
63
-
let main ~env = Switch.run @@ fun sw -> run_test ~sw ~env
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)
64
122
65
-
(* Command-line interface *)
66
-
open Cmdliner
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))
67
128
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
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
+
}
82
137
in
83
-
Term.(const run $ Fmt_cli.style_renderer () $ Logs_cli.level ())
138
+
let d = P.default_allow ctx in
139
+
Alcotest.(check bool) "allows" true (P.Decision.is_allow d)
84
140
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)
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))
89
158
90
-
let () = Eio_main.run @@ fun env -> exit (Cmd.eval (cmd env))
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
+73
test/test_structured_output.ml
+73
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 = Json.Value
10
+
11
+
let mk_schema () =
12
+
J.object'
13
+
[
14
+
J.member (J.name "type") (J.string "object");
15
+
J.member (J.name "properties")
16
+
(J.object'
17
+
[
18
+
J.member (J.name "name")
19
+
(J.object' [ J.member (J.name "type") (J.string "string") ]);
20
+
]);
21
+
J.member (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
+
| Json.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
+
| Json.Object _ -> ()
39
+
| _ -> Alcotest.fail "Expected object schema after roundtrip"
40
+
41
+
let test_jsont_encode_decode () =
42
+
let schema = J.object' [ J.member (J.name "type") (J.string "string") ] in
43
+
let so = SO.of_json_schema schema in
44
+
let json = Json.encode SO.json so in
45
+
match Json.decode SO.json json with
46
+
| Ok back -> (
47
+
match SO.json_schema back with
48
+
| Json.Object _ -> ()
49
+
| _ -> Alcotest.fail "Expected object after decode")
50
+
| Error e -> Alcotest.fail (Json.Error.to_string e)
51
+
52
+
let test_simple_string_schema () =
53
+
let schema = J.object' [ J.member (J.name "type") (J.string "string") ] in
54
+
let so = SO.of_json_schema schema in
55
+
match SO.json_schema so with
56
+
| Json.Object _ -> ()
57
+
| _ -> Alcotest.fail "Expected object"
58
+
59
+
let test_of_json_invalid () =
60
+
(* of_json with bad data should raise Invalid_argument *)
61
+
match SO.of_json (Json.String ("not valid", Json.Meta.none)) with
62
+
| exception Invalid_argument _ -> ()
63
+
| _ -> Alcotest.fail "Expected Invalid_argument for bad JSON"
64
+
65
+
let suite =
66
+
( "structured_output",
67
+
[
68
+
Alcotest.test_case "of_json_schema" `Quick test_of_json_schema;
69
+
Alcotest.test_case "to_json/of_json roundtrip" `Quick test_json_roundtrip;
70
+
Alcotest.test_case "json encode/decode" `Quick test_jsont_encode_decode;
71
+
Alcotest.test_case "simple string schema" `Quick test_simple_string_schema;
72
+
Alcotest.test_case "of_json invalid" `Quick test_of_json_invalid;
73
+
] )
+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 = Json.Value
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
+
| Json.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
+
| Json.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
+
| Json.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
+
| Json.Array ([ Json.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
+
| Json.Array ([ Json.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.member (J.name "type") (J.string "text");
83
+
J.member (J.name "text") (J.string "line1");
84
+
];
85
+
J.object'
86
+
[
87
+
J.member (J.name "type") (J.string "text");
88
+
J.member (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 (Json.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 = Json.Value
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.member (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", Json.Number (42.0, Json.Meta.none));
95
+
("s", Json.String ("hi", Json.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.member (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", Json.String ("val", Json.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", Json.String ("val1", Json.Meta.none));
24
+
("key2", Json.Number (42.0, Json.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
+
] )