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