anil.recoil.org
OCaml Claude SDK using Eio and Jsont
refine jsont use
+83
-57
lib/client.ml
+83
-57
lib/client.ml
···
1
1
let src = Logs.Src.create "claude.client" ~doc:"Claude client"
2
2
module Log = (val Logs.src_log src : Logs.LOG)
3
3
4
-
(** Control response builders using jsont *)
4
+
(** Control response builders using Sdk_control codecs *)
5
5
module Control_response = struct
6
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
-
]
7
+
let resp = Sdk_control.Response.success ~request_id ?response () in
8
+
let ctrl = Sdk_control.create_response ~response:resp () in
9
+
match Jsont.Json.encode Sdk_control.jsont ctrl with
10
+
| Ok json -> json
11
+
| Error msg -> failwith ("Control_response.success: " ^ msg)
15
12
16
13
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
-
]
14
+
let resp = Sdk_control.Response.error ~request_id ~error:message () in
15
+
let ctrl = Sdk_control.create_response ~response:resp () in
16
+
match Jsont.Json.encode Sdk_control.jsont ctrl with
17
+
| Ok json -> json
18
+
| Error msg -> failwith ("Control_response.error: " ^ msg)
25
19
end
26
20
27
21
(* Helper functions for JSON manipulation using jsont *)
···
30
24
| Ok s -> s
31
25
| Error err -> failwith (Jsont.Error.to_string err)
32
26
33
-
(* JSON construction helpers using jsont *)
34
-
let json_string s = Jsont.Json.string s
35
-
let json_null () = Jsont.Json.null ()
27
+
(** Wire-level codec for permission responses to CLI.
28
+
Uses camelCase field names as expected by the CLI protocol. *)
29
+
module Permission_wire = struct
30
+
type allow = { allow_behavior : string; allow_updated_input : Jsont.json }
31
+
type deny = { deny_behavior : string; deny_message : string }
36
32
37
-
let json_object pairs =
38
-
Jsont.Json.object' (List.map (fun (k, v) -> Jsont.Json.mem (Jsont.Json.name k) v) pairs)
33
+
let allow_jsont : allow Jsont.t =
34
+
let make allow_behavior allow_updated_input = { allow_behavior; allow_updated_input } in
35
+
Jsont.Object.map ~kind:"AllowWire" make
36
+
|> Jsont.Object.mem "behavior" Jsont.string ~enc:(fun r -> r.allow_behavior)
37
+
|> Jsont.Object.mem "updatedInput" Jsont.json ~enc:(fun r -> r.allow_updated_input)
38
+
|> Jsont.Object.finish
39
+
40
+
let deny_jsont : deny Jsont.t =
41
+
let make deny_behavior deny_message = { deny_behavior; deny_message } in
42
+
Jsont.Object.map ~kind:"DenyWire" make
43
+
|> Jsont.Object.mem "behavior" Jsont.string ~enc:(fun r -> r.deny_behavior)
44
+
|> Jsont.Object.mem "message" Jsont.string ~enc:(fun r -> r.deny_message)
45
+
|> Jsont.Object.finish
46
+
47
+
let encode_allow ~updated_input =
48
+
match Jsont.Json.encode allow_jsont { allow_behavior = "allow"; allow_updated_input = updated_input } with
49
+
| Ok json -> json
50
+
| Error msg -> failwith ("Permission_wire.encode_allow: " ^ msg)
51
+
52
+
let encode_deny ~message =
53
+
match Jsont.Json.encode deny_jsont { deny_behavior = "deny"; deny_message = message } with
54
+
| Ok json -> json
55
+
| Error msg -> failwith ("Permission_wire.encode_deny: " ^ msg)
56
+
end
57
+
58
+
(** Wire-level codec for hook matcher configuration sent to CLI. *)
59
+
module Hook_matcher_wire = struct
60
+
type t = {
61
+
matcher : string option;
62
+
hook_callback_ids : string list;
63
+
}
64
+
65
+
let jsont : t Jsont.t =
66
+
let make matcher hook_callback_ids = { matcher; hook_callback_ids } in
67
+
Jsont.Object.map ~kind:"HookMatcherWire" make
68
+
|> Jsont.Object.opt_mem "matcher" Jsont.string ~enc:(fun r -> r.matcher)
69
+
|> Jsont.Object.mem "hookCallbackIds" (Jsont.list Jsont.string) ~enc:(fun r -> r.hook_callback_ids)
70
+
|> Jsont.Object.finish
71
+
72
+
let encode matchers =
73
+
Jsont.Json.list (List.map (fun m ->
74
+
match Jsont.Json.encode jsont m with
75
+
| Ok json -> json
76
+
| Error msg -> failwith ("Hook_matcher_wire.encode: " ^ msg)
77
+
) matchers)
78
+
end
39
79
40
80
type t = {
41
81
transport : Transport.t;
42
82
permission_callback : Permissions.callback option;
43
83
permission_log : Permissions.Rule.t list ref option;
44
84
hook_callbacks : (string, Hooks.callback) Hashtbl.t;
45
-
mutable next_callback_id : int;
46
85
mutable session_id : string option;
47
86
control_responses : (string, Jsont.json) Hashtbl.t;
48
87
control_mutex : Eio.Mutex.t;
49
88
control_condition : Eio.Condition.t;
50
89
}
90
+
91
+
let session_id t = t.session_id
51
92
52
93
let handle_control_request t (ctrl_req : Incoming.Control_request.t) =
53
94
let request_id = Incoming.Control_request.request_id ctrl_req in
···
76
117
| Permissions.Result.Allow _ -> "ALLOW"
77
118
| Permissions.Result.Deny _ -> "DENY"));
78
119
79
-
(* Convert permission result to CLI format *)
120
+
(* Convert permission result to CLI format using wire codec *)
80
121
let response_data = match result with
81
122
| Permissions.Result.Allow { updated_input; updated_permissions = _; unknown = _ } ->
82
123
let updated_input = Option.value updated_input ~default:input in
83
-
json_object [
84
-
("behavior", json_string "allow");
85
-
("updatedInput", updated_input);
86
-
]
124
+
Permission_wire.encode_allow ~updated_input
87
125
| Permissions.Result.Deny { message; interrupt = _; unknown = _ } ->
88
-
json_object [
89
-
("behavior", json_string "deny");
90
-
("message", json_string message);
91
-
]
126
+
Permission_wire.encode_deny ~message
92
127
in
93
-
let response = Control_response.success ~request_id ~response:response_data in
128
+
let response = Control_response.success ~request_id ~response:(Some response_data) in
94
129
Log.info (fun m -> m "Sending control response: %s" (json_to_string response));
95
130
Transport.send t.transport response
96
131
···
109
144
| Ok j -> j
110
145
| Error msg -> failwith ("Failed to encode hook result: " ^ msg)
111
146
in
112
-
let response = Control_response.success ~request_id ~response:result_json in
147
+
let response = Control_response.success ~request_id ~response:(Some result_json) in
113
148
Log.info (fun m -> m "Hook callback succeeded, sending response");
114
149
Transport.send t.transport response
115
150
with
···
208
243
permission_callback = Options.permission_callback options;
209
244
permission_log = None;
210
245
hook_callbacks;
211
-
next_callback_id = 0;
212
246
session_id = None;
213
247
control_responses = Hashtbl.create 16;
214
248
control_mutex = Eio.Mutex.create ();
···
220
254
| Some hooks_config ->
221
255
Log.info (fun m -> m "Registering hooks...");
222
256
223
-
(* Build hooks configuration with callback IDs *)
224
-
let hooks_json = List.fold_left (fun acc (event, matchers) ->
257
+
(* Build hooks configuration with callback IDs as (string * Jsont.json) list *)
258
+
let hooks_list = List.map (fun (event, matchers) ->
225
259
let event_name = Hooks.event_to_string event in
226
-
let matchers_json = List.map (fun matcher ->
260
+
let matcher_wires = List.map (fun matcher ->
227
261
let callback_ids = List.map (fun callback ->
228
262
let callback_id = Printf.sprintf "hook_%d" !next_callback_id in
229
263
incr next_callback_id;
···
231
265
Log.debug (fun m -> m "Registered callback: %s for event: %s" callback_id event_name);
232
266
callback_id
233
267
) 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
-
]
268
+
Hook_matcher_wire.{ matcher = matcher.Hooks.matcher; hook_callback_ids = callback_ids }
240
269
) matchers in
241
-
(event_name, Jsont.Json.list matchers_json) :: acc
242
-
) [] hooks_config in
270
+
(event_name, Hook_matcher_wire.encode matcher_wires)
271
+
) hooks_config in
243
272
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
273
+
(* Create initialize request using Sdk_control codec *)
274
+
let request = Sdk_control.Request.initialize ~hooks:hooks_list () in
275
+
let ctrl_req = Sdk_control.create_request ~request_id:"init_hooks" ~request () in
276
+
let initialize_msg = match Jsont.Json.encode Sdk_control.jsont ctrl_req with
277
+
| Ok json -> json
278
+
| Error msg -> failwith ("Failed to encode initialize request: " ^ msg)
279
+
in
253
280
Log.info (fun m -> m "Sending hooks initialize request");
254
-
Transport.send t.transport initialize_msg;
255
-
t.next_callback_id <- !next_callback_id
281
+
Transport.send t.transport initialize_msg
256
282
| None -> ());
257
283
258
284
t
+5
lib/client.mli
+5
lib/client.mli
···
47
47
type t
48
48
(** The type of Claude clients. *)
49
49
50
+
val session_id : t -> string option
51
+
(** [session_id t] returns the session ID if one has been received from Claude.
52
+
The session ID is provided in system init messages and uniquely identifies
53
+
the current conversation session. *)
54
+
50
55
val create :
51
56
?options:Options.t ->
52
57
sw:Eio.Switch.t ->
-52
lib/content_block.ml
-52
lib/content_block.ml
···
20
20
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
21
21
|> Jsont.Object.finish
22
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
23
let pp fmt t =
34
24
if String.length t.text > 60 then
35
25
let truncated = String.sub t.text 0 57 in
···
74
64
| Jsont.Object (members, _) -> List.map (fun ((name, _), _) -> name) members
75
65
| _ -> []
76
66
77
-
let to_json t = t
78
-
let of_json json = json
79
67
end
80
68
81
69
type t = {
···
101
89
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
102
90
|> Jsont.Object.finish
103
91
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
92
let pp fmt t =
115
93
let keys = Input.keys t.input in
116
94
let key_info = match keys with
···
147
125
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
148
126
|> Jsont.Object.finish
149
127
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
128
let pp fmt t =
161
129
match t.is_error, t.content with
162
130
| Some true, Some c ->
···
195
163
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
196
164
|> Jsont.Object.finish
197
165
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
166
let pp fmt t =
209
167
if String.length t.thinking > 50 then
210
168
let truncated = String.sub t.thinking 0 47 in
···
252
210
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
253
211
~tag_to_string:Fun.id ~tag_compare:String.compare
254
212
|> 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
213
266
214
let pp fmt = function
267
215
| Text t -> Text.pp fmt t
+10
-45
lib/content_block.mli
+10
-45
lib/content_block.mli
···
24
24
(** [unknown t] returns any unknown fields from JSON parsing. *)
25
25
26
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. *)
27
+
(** [jsont] is the Jsont codec for text blocks.
28
+
Use [Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization. *)
35
29
36
30
val pp : Format.formatter -> t -> unit
37
31
(** [pp fmt t] pretty-prints the text block. *)
···
72
66
val keys : t -> string list
73
67
(** [keys t] returns all keys in the input. *)
74
68
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
69
end
81
70
82
71
type t
···
101
90
(** [unknown t] returns any unknown fields from JSON parsing. *)
102
91
103
92
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. *)
93
+
(** [jsont] is the Jsont codec for tool use blocks.
94
+
Use [Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization. *)
112
95
113
96
val pp : Format.formatter -> t -> unit
114
97
(** [pp fmt t] pretty-prints the tool use block. *)
···
141
124
(** [unknown t] returns any unknown fields from JSON parsing. *)
142
125
143
126
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. *)
127
+
(** [jsont] is the Jsont codec for tool result blocks.
128
+
Use [Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization. *)
152
129
153
130
val pp : Format.formatter -> t -> unit
154
131
(** [pp fmt t] pretty-prints the tool result block. *)
···
177
154
(** [unknown t] returns any unknown fields from JSON parsing. *)
178
155
179
156
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. *)
157
+
(** [jsont] is the Jsont codec for thinking blocks.
158
+
Use [Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization. *)
188
159
189
160
val pp : Format.formatter -> t -> unit
190
161
(** [pp fmt t] pretty-prints the thinking block. *)
···
212
183
(** [thinking ~thinking ~signature] creates a thinking content block. *)
213
184
214
185
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. *)
186
+
(** [jsont] is the Jsont codec for content blocks.
187
+
Use [Jsont.Json.encode jsont] and [Jsont.Json.decode jsont] for serialization. *)
223
188
224
189
val pp : Format.formatter -> t -> unit
225
190
(** [pp fmt t] pretty-prints any content block. *)
+18
-7
lib/hooks.ml
+18
-7
lib/hooks.ml
···
435
435
| Ok json -> json
436
436
| Error msg -> failwith ("result_to_json: " ^ msg)
437
437
438
+
(** Wire codec for hook matcher in protocol format *)
439
+
module Protocol_matcher_wire = struct
440
+
type t = { matcher : string option; callbacks : Jsont.json list }
441
+
442
+
let jsont : t Jsont.t =
443
+
let make matcher callbacks = { matcher; callbacks } in
444
+
Jsont.Object.map ~kind:"ProtocolMatcher" make
445
+
|> Jsont.Object.opt_mem "matcher" Jsont.string ~enc:(fun r -> r.matcher)
446
+
|> Jsont.Object.mem "callbacks" (Jsont.list Jsont.json) ~enc:(fun r -> r.callbacks)
447
+
|> Jsont.Object.finish
448
+
449
+
let encode m =
450
+
match Jsont.Json.encode jsont m with
451
+
| Ok json -> json
452
+
| Error msg -> failwith ("Protocol_matcher_wire.encode: " ^ msg)
453
+
end
454
+
438
455
let config_to_protocol_format config =
439
456
let hooks_dict = List.map (fun (event, matchers) ->
440
457
let event_name = event_to_string event in
441
458
let matchers_json = List.map (fun m ->
442
459
(* 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
460
+
Protocol_matcher_wire.encode { matcher = m.matcher; callbacks = [] }
450
461
) matchers in
451
462
Jsont.Json.mem (Jsont.Json.name event_name) (Jsont.Json.list matchers_json)
452
463
) config in
+138
-60
lib/message.ml
+138
-60
lib/message.ml
···
59
59
(* Encode content to json value *)
60
60
let encode_content = function
61
61
| String s -> Jsont.String (s, Jsont.Meta.none)
62
-
| Blocks blocks -> Jsont.Array (List.map Content_block.to_json blocks, Jsont.Meta.none)
62
+
| Blocks blocks ->
63
+
let jsons = List.map (fun b ->
64
+
match Jsont.Json.encode Content_block.jsont b with
65
+
| Ok j -> j
66
+
| Error msg -> failwith ("encode_content: " ^ msg)
67
+
) blocks in
68
+
Jsont.Array (jsons, Jsont.Meta.none)
63
69
64
70
let jsont : t Jsont.t =
65
71
Jsont.Object.map ~kind:"User" (fun json_content unknown ->
···
70
76
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
71
77
|> Jsont.Object.finish
72
78
79
+
(** Wire-format codec for outgoing user messages.
80
+
Format: {"type": "user", "message": {"role": "user", "content": ...}} *)
81
+
module Wire = struct
82
+
type inner = { role : string; content : Jsont.json }
83
+
type outer = { type_ : string; message : inner }
84
+
85
+
let inner_jsont : inner Jsont.t =
86
+
let make role content = { role; content } in
87
+
Jsont.Object.map ~kind:"UserMessageInner" make
88
+
|> Jsont.Object.mem "role" Jsont.string ~enc:(fun r -> r.role)
89
+
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun r -> r.content)
90
+
|> Jsont.Object.finish
91
+
92
+
let outer_jsont : outer Jsont.t =
93
+
let make type_ message = { type_; message } in
94
+
Jsont.Object.map ~kind:"UserMessageOuter" make
95
+
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun r -> r.type_)
96
+
|> Jsont.Object.mem "message" inner_jsont ~enc:(fun r -> r.message)
97
+
|> Jsont.Object.finish
98
+
end
99
+
73
100
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)
101
+
let content_json = encode_content t.content in
102
+
let wire = Wire.{
103
+
type_ = "user";
104
+
message = { role = "user"; content = content_json }
105
+
} in
106
+
match Jsont.Json.encode Wire.outer_jsont wire with
107
+
| Ok json -> json
108
+
| Error msg -> failwith ("User.to_json: " ^ msg)
86
109
87
110
(* Jsont codec for parsing incoming user messages from CLI *)
88
111
let incoming_jsont : t Jsont.t =
···
215
238
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
216
239
|> Jsont.Object.finish
217
240
241
+
let encode_content_blocks blocks =
242
+
let jsons = List.map (fun b ->
243
+
match Jsont.Json.encode Content_block.jsont b with
244
+
| Ok j -> j
245
+
| Error msg -> failwith ("encode_content_blocks: " ^ msg)
246
+
) blocks in
247
+
Jsont.Array (jsons, Jsont.Meta.none)
248
+
249
+
(** Wire-format codec for outgoing assistant messages. *)
250
+
module Wire = struct
251
+
type inner = {
252
+
wire_content : Jsont.json;
253
+
wire_model : string;
254
+
wire_error : string option;
255
+
}
256
+
type outer = { wire_type : string; wire_message : inner }
257
+
258
+
let inner_jsont : inner Jsont.t =
259
+
let make wire_content wire_model wire_error = { wire_content; wire_model; wire_error } in
260
+
Jsont.Object.map ~kind:"AssistantMessageInner" make
261
+
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun r -> r.wire_content)
262
+
|> Jsont.Object.mem "model" Jsont.string ~enc:(fun r -> r.wire_model)
263
+
|> Jsont.Object.opt_mem "error" Jsont.string ~enc:(fun r -> r.wire_error)
264
+
|> Jsont.Object.finish
265
+
266
+
let outer_jsont : outer Jsont.t =
267
+
let make wire_type wire_message = { wire_type; wire_message } in
268
+
Jsont.Object.map ~kind:"AssistantMessageOuter" make
269
+
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun r -> r.wire_type)
270
+
|> Jsont.Object.mem "message" inner_jsont ~enc:(fun r -> r.wire_message)
271
+
|> Jsont.Object.finish
272
+
end
273
+
218
274
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)
275
+
let wire = Wire.{
276
+
wire_type = "assistant";
277
+
wire_message = {
278
+
wire_content = encode_content_blocks t.content;
279
+
wire_model = t.model;
280
+
wire_error = Option.map error_to_string t.error;
281
+
}
282
+
} in
283
+
match Jsont.Json.encode Wire.outer_jsont wire with
284
+
| Ok json -> json
285
+
| Error msg -> failwith ("Assistant.to_json: " ^ msg)
231
286
232
287
(* Jsont codec for parsing incoming assistant messages from CLI *)
233
288
let incoming_jsont : t Jsont.t =
···
448
503
Fmt.(option int) t.cache_creation_input_tokens
449
504
Fmt.(option int) t.cache_read_input_tokens
450
505
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
506
end
461
507
462
508
type t = {
···
510
556
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
511
557
|> Jsont.Object.finish
512
558
559
+
(** Wire-format codec for outgoing result messages (adds "type" field). *)
560
+
module Wire = struct
561
+
type wire = {
562
+
type_ : string;
563
+
subtype : string;
564
+
duration_ms : int;
565
+
duration_api_ms : int;
566
+
is_error : bool;
567
+
num_turns : int;
568
+
session_id : string;
569
+
total_cost_usd : float option;
570
+
usage : Jsont.json option;
571
+
result : string option;
572
+
structured_output : Jsont.json option;
573
+
}
574
+
575
+
let jsont : wire Jsont.t =
576
+
let make type_ subtype duration_ms duration_api_ms is_error num_turns
577
+
session_id total_cost_usd usage result structured_output =
578
+
{ type_; subtype; duration_ms; duration_api_ms; is_error; num_turns;
579
+
session_id; total_cost_usd; usage; result; structured_output }
580
+
in
581
+
Jsont.Object.map ~kind:"ResultWire" make
582
+
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun r -> r.type_)
583
+
|> Jsont.Object.mem "subtype" Jsont.string ~enc:(fun r -> r.subtype)
584
+
|> Jsont.Object.mem "duration_ms" Jsont.int ~enc:(fun r -> r.duration_ms)
585
+
|> Jsont.Object.mem "duration_api_ms" Jsont.int ~enc:(fun r -> r.duration_api_ms)
586
+
|> Jsont.Object.mem "is_error" Jsont.bool ~enc:(fun r -> r.is_error)
587
+
|> Jsont.Object.mem "num_turns" Jsont.int ~enc:(fun r -> r.num_turns)
588
+
|> Jsont.Object.mem "session_id" Jsont.string ~enc:(fun r -> r.session_id)
589
+
|> Jsont.Object.opt_mem "total_cost_usd" Jsont.number ~enc:(fun r -> r.total_cost_usd)
590
+
|> Jsont.Object.opt_mem "usage" Jsont.json ~enc:(fun r -> r.usage)
591
+
|> Jsont.Object.opt_mem "result" Jsont.string ~enc:(fun r -> r.result)
592
+
|> Jsont.Object.opt_mem "structured_output" Jsont.json ~enc:(fun r -> r.structured_output)
593
+
|> Jsont.Object.finish
594
+
end
595
+
513
596
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)
597
+
let usage_json = Option.map (fun u ->
598
+
match Jsont.Json.encode Usage.jsont u with
599
+
| Ok j -> j
600
+
| Error msg -> failwith ("Result.to_json: usage: " ^ msg)
601
+
) t.usage in
602
+
let wire = Wire.{
603
+
type_ = "result";
604
+
subtype = t.subtype;
605
+
duration_ms = t.duration_ms;
606
+
duration_api_ms = t.duration_api_ms;
607
+
is_error = t.is_error;
608
+
num_turns = t.num_turns;
609
+
session_id = t.session_id;
610
+
total_cost_usd = t.total_cost_usd;
611
+
usage = usage_json;
612
+
result = t.result;
613
+
structured_output = t.structured_output;
614
+
} in
615
+
match Jsont.Json.encode Wire.jsont wire with
616
+
| Ok json -> json
617
+
| Error msg -> failwith ("Result.to_json: " ^ msg)
540
618
541
619
let of_json json =
542
620
match Jsont.Json.decode jsont json with
-6
lib/message.mli
-6
lib/message.mli
···
269
269
270
270
val pp : Format.formatter -> t -> unit
271
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
272
end
279
273
280
274
type t
+3
-1
lib/options.ml
+3
-1
lib/options.ml
···
218
218
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
219
219
|> Jsont.Object.finish
220
220
221
+
(*
221
222
let to_json t =
222
223
match Jsont.Json.encode jsont t with
223
224
| Ok json -> json
···
227
228
match Jsont.Json.decode jsont json with
228
229
| Ok t -> t
229
230
| Error msg -> raise (Invalid_argument ("Options.of_json: " ^ msg))
231
+
*)
230
232
231
233
let pp fmt t =
232
234
Fmt.pf fmt "@[<v>Options {@ \
···
249
251
Fmt.(list (pair string string)) t.env
250
252
251
253
let log_options t =
252
-
Log.debug (fun m -> m "Claude options: %a" pp t)
254
+
Log.debug (fun m -> m "Claude options: %a" pp t)
+1
-8
lib/options.mli
+1
-8
lib/options.mli
···
356
356
val jsont : t Jsont.t
357
357
(** [jsont] is the Jsont codec for Options.t *)
358
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
359
val pp : Format.formatter -> t -> unit
367
360
(** [pp fmt t] pretty-prints the options. *)
368
361
369
362
(** {1 Logging} *)
370
363
371
364
val log_options : t -> unit
372
-
(** [log_options t] logs the current options configuration. *)
365
+
(** [log_options t] logs the current options configuration. *)
+28
-11
lib/transport.ml
+28
-11
lib/transport.ml
···
14
14
stdin : Eio.Flow.sink_ty r;
15
15
stdin_close : [`Close | `Flow] r;
16
16
stdout : Eio.Buf_read.t;
17
-
sw : Switch.t;
18
17
}
19
18
20
19
let setting_source_to_string = function
···
162
161
in
163
162
let stdout = Eio.Buf_read.of_flow ~max_size (stdout_r :> Eio.Flow.source_ty r) in
164
163
165
-
{ process = P process; stdin; stdin_close; stdout; sw }
164
+
{ process = P process; stdin; stdin_close; stdout }
166
165
167
166
let send t json =
168
167
let data = match Jsont_bytesrw.encode_string' Jsont.json json with
···
191
190
Log.err (fun m -> m "Failed to receive message: %s" (Printexc.to_string exn));
192
191
raise (Connection_error (Printf.sprintf "Failed to receive message: %s" (Printexc.to_string exn)))
193
192
193
+
(** Wire codec for interrupt response messages. *)
194
+
module Interrupt_wire = struct
195
+
type inner = { subtype : string; request_id : string }
196
+
type t = { type_ : string; response : inner }
197
+
198
+
let inner_jsont : inner Jsont.t =
199
+
let make subtype request_id = { subtype; request_id } in
200
+
Jsont.Object.map ~kind:"InterruptInner" make
201
+
|> Jsont.Object.mem "subtype" Jsont.string ~enc:(fun r -> r.subtype)
202
+
|> Jsont.Object.mem "request_id" Jsont.string ~enc:(fun r -> r.request_id)
203
+
|> Jsont.Object.finish
204
+
205
+
let jsont : t Jsont.t =
206
+
let make type_ response = { type_; response } in
207
+
Jsont.Object.map ~kind:"InterruptOuter" make
208
+
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun r -> r.type_)
209
+
|> Jsont.Object.mem "response" inner_jsont ~enc:(fun r -> r.response)
210
+
|> Jsont.Object.finish
211
+
212
+
let encode () =
213
+
let wire = { type_ = "control_response"; response = { subtype = "interrupt"; request_id = "" } } in
214
+
match Jsont.Json.encode jsont wire with
215
+
| Ok json -> json
216
+
| Error msg -> failwith ("Interrupt_wire.encode: " ^ msg)
217
+
end
218
+
194
219
let interrupt t =
195
220
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
221
+
let interrupt_msg = Interrupt_wire.encode () in
205
222
send t interrupt_msg
206
223
207
224
let close t =