this repo has no description
sync
+695
-689
+98
-164
claudeio/lib/client.ml
+98
-164
claudeio/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
-
(* Helper functions for JSON manipulation *)
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 *)
5
28
let json_to_string json =
6
29
match Jsont_bytesrw.encode_string' Jsont.json json with
7
30
| Ok s -> s
8
31
| Error err -> failwith (Jsont.Error.to_string err)
9
32
10
-
let json_of_string s =
11
-
match Jsont_bytesrw.decode_string' Jsont.json s with
12
-
| Ok j -> j
13
-
| Error err -> failwith (Jsont.Error.to_string err)
14
-
15
-
let get_field json key =
16
-
match json with
17
-
| Jsont.Object (members, _) ->
18
-
List.find_map (fun ((name, _), value) ->
19
-
if name = key then Some value else None
20
-
) members
21
-
| _ -> None
33
+
(* JSON construction helpers using jsont *)
34
+
let json_string s = Jsont.Json.string s
35
+
let json_null () = Jsont.Json.null ()
22
36
23
-
let rec find json path =
24
-
match path with
25
-
| [] -> json
26
-
| key :: rest ->
27
-
match get_field json key with
28
-
| Some value -> find value rest
29
-
| None -> raise Not_found
30
-
31
-
let find_string json path =
32
-
let value = find json path in
33
-
match value with
34
-
| Jsont.String (s, _) -> s
35
-
| _ -> raise (Invalid_argument "Expected string value")
36
-
37
-
let json_string s = Jsont.String (s, Jsont.Meta.none)
38
-
let json_null = Jsont.Null ((), Jsont.Meta.none)
39
-
40
-
let json_dict pairs =
41
-
let members = List.map (fun (k, v) -> ((k, Jsont.Meta.none), v)) pairs in
42
-
Jsont.Object (members, Jsont.Meta.none)
37
+
let json_object pairs =
38
+
Jsont.Json.object' (List.map (fun (k, v) -> Jsont.Json.mem (Jsont.Json.name k) v) pairs)
43
39
44
40
type t = {
45
41
transport : Transport.t;
···
53
49
control_condition : Eio.Condition.t;
54
50
}
55
51
56
-
let handle_control_request t control_msg =
57
-
let data = Control.data control_msg in
58
-
Log.info (fun m -> m "Handling control request: %s" (Control.subtype control_msg));
59
-
Log.info (fun m -> m "Control request data: %s" (json_to_string data));
60
-
match find_string data ["request"; "subtype"] with
61
-
| "can_use_tool" ->
62
-
let tool_name = find_string data ["request"; "tool_name"] in
63
-
let input = find data ["request"; "input"] in
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
64
60
Log.info (fun m -> m "Permission request for tool '%s' with input: %s"
65
61
tool_name (json_to_string input));
66
-
let suggestions =
67
-
try
68
-
let sugg_json = find data ["request"; "permission_suggestions"] in
69
-
match sugg_json with
70
-
| Jsont.Array _ ->
71
-
(* TODO: Parse permission suggestions *)
72
-
[]
73
-
| _ -> []
74
-
with Not_found -> []
75
-
in
76
-
let context = Permissions.Context.create ~suggestions () in
62
+
(* TODO: Parse permission_suggestions properly *)
63
+
let context = Permissions.Context.create ~suggestions:[] () in
77
64
78
65
Log.info (fun m -> m "Invoking permission callback for tool: %s" tool_name);
79
66
let result = match t.permission_callback with
···
89
76
| Permissions.Result.Allow _ -> "ALLOW"
90
77
| Permissions.Result.Deny _ -> "DENY"));
91
78
92
-
(* Convert permission result to CLI format: {"behavior": "allow", "updatedInput": ...} or {"behavior": "deny", "message": ...} *)
79
+
(* Convert permission result to CLI format *)
93
80
let response_data = match result with
94
81
| Permissions.Result.Allow { updated_input; updated_permissions = _; unknown = _ } ->
95
-
(* updatedInput is required when allowing - use original input if not modified *)
96
-
let updated_input = match updated_input with
97
-
| Some inp -> inp
98
-
| None -> input (* Use original input *)
99
-
in
100
-
json_dict [
82
+
let updated_input = Option.value updated_input ~default:input in
83
+
json_object [
101
84
("behavior", json_string "allow");
102
85
("updatedInput", updated_input);
103
86
]
104
87
| Permissions.Result.Deny { message; interrupt = _; unknown = _ } ->
105
-
json_dict [
88
+
json_object [
106
89
("behavior", json_string "deny");
107
90
("message", json_string message);
108
91
]
109
92
in
110
-
111
-
let response = json_dict [
112
-
"type", json_string "control_response";
113
-
"response", json_dict [
114
-
"subtype", json_string "success";
115
-
"request_id", json_string (Control.request_id control_msg);
116
-
"response", response_data
117
-
]
118
-
] in
93
+
let response = Control_response.success ~request_id ~response:response_data in
119
94
Log.info (fun m -> m "Sending control response: %s" (json_to_string response));
120
95
Transport.send t.transport response
121
-
122
-
| "hook_callback" ->
123
-
let callback_id = find_string data ["request"; "callback_id"] in
124
-
let input = find data ["request"; "input"] in
125
-
let tool_use_id =
126
-
try Some (find_string data ["request"; "tool_use_id"])
127
-
with Not_found -> None
128
-
in
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
129
101
Log.info (fun m -> m "Hook callback request for callback_id: %s" callback_id);
130
102
131
103
(try
···
137
109
| Ok j -> j
138
110
| Error msg -> failwith ("Failed to encode hook result: " ^ msg)
139
111
in
140
-
141
-
let response = json_dict [
142
-
"type", json_string "control_response";
143
-
"response", json_dict [
144
-
"subtype", json_string "success";
145
-
"request_id", json_string (Control.request_id control_msg);
146
-
"response", result_json
147
-
]
148
-
] in
112
+
let response = Control_response.success ~request_id ~response:result_json in
149
113
Log.info (fun m -> m "Hook callback succeeded, sending response");
150
114
Transport.send t.transport response
151
115
with
152
116
| Not_found ->
153
117
let error_msg = Printf.sprintf "Hook callback not found: %s" callback_id in
154
118
Log.err (fun m -> m "%s" error_msg);
155
-
let response = json_dict [
156
-
"type", json_string "control_response";
157
-
"response", json_dict [
158
-
"subtype", json_string "error";
159
-
"request_id", json_string (Control.request_id control_msg);
160
-
"error", json_string error_msg
161
-
]
162
-
] in
163
-
Transport.send t.transport response
119
+
Transport.send t.transport (Control_response.error ~request_id ~message:error_msg)
164
120
| exn ->
165
121
let error_msg = Printf.sprintf "Hook callback error: %s" (Printexc.to_string exn) in
166
122
Log.err (fun m -> m "%s" error_msg);
167
-
let response = json_dict [
168
-
"type", json_string "control_response";
169
-
"response", json_dict [
170
-
"subtype", json_string "error";
171
-
"request_id", json_string (Control.request_id control_msg);
172
-
"error", json_string error_msg
173
-
]
174
-
] in
175
-
Transport.send t.transport response)
123
+
Transport.send t.transport (Control_response.error ~request_id ~message:error_msg))
176
124
177
-
| subtype ->
178
-
(* Respond with error for unknown control requests *)
179
-
let response = json_dict [
180
-
"type", json_string "control_response";
181
-
"response", json_dict [
182
-
"subtype", json_string "error";
183
-
"request_id", json_string (Control.request_id control_msg);
184
-
"error", json_string (Printf.sprintf "Unsupported control request: %s" subtype)
185
-
]
186
-
] in
187
-
Transport.send t.transport response
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)
188
128
189
129
let handle_control_response t control_resp =
190
130
let request_id = match control_resp.Sdk_control.response with
···
211
151
Log.debug (fun m -> m "Handle messages: EOF received");
212
152
Seq.Nil
213
153
| Some line ->
214
-
try
215
-
(* First check if it's a control_request (special case, not in Incoming) *)
216
-
let json = json_of_string line in
217
-
match find_string json ["type"] with
218
-
| "control_request" ->
219
-
let control_msg = Control.create
220
-
~request_id:(find_string json ["request_id"])
221
-
~subtype:(find_string json ["request"; "subtype"])
222
-
~data:json in
223
-
Log.info (fun m -> m "Received control request: %s (request_id: %s)"
224
-
(Control.subtype control_msg) (Control.request_id control_msg));
225
-
handle_control_request t control_msg;
226
-
loop ()
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);
227
158
228
-
| _ ->
229
-
(* Use Incoming codec for all other message types *)
230
-
match Jsont_bytesrw.decode_string' Incoming.jsont line with
231
-
| Ok (Incoming.Message msg) ->
232
-
Log.info (fun m -> m "← %a" Message.pp msg);
159
+
(* Extract session ID from system messages *)
160
+
(match msg with
161
+
| Message.System sys ->
162
+
(match Message.System.Data.session_id (Message.System.data 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
+
| _ -> ());
233
168
234
-
(* Extract session ID from system messages *)
235
-
(match msg with
236
-
| Message.System sys when Message.System.subtype sys = "init" ->
237
-
(match Message.System.Data.get_string (Message.System.data sys) "session_id" with
238
-
| Some session_id ->
239
-
t.session_id <- Some session_id;
240
-
Log.debug (fun m -> m "Stored session ID: %s" session_id)
241
-
| None -> ())
242
-
| _ -> ());
169
+
Seq.Cons (msg, loop)
243
170
244
-
Seq.Cons (msg, loop)
171
+
| Ok (Incoming.Control_response resp) ->
172
+
handle_control_response t resp;
173
+
loop ()
245
174
246
-
| Ok (Incoming.Control_response resp) ->
247
-
handle_control_response t resp;
248
-
loop ()
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 ()
249
181
250
-
| Error err ->
251
-
Log.err (fun m -> m "Failed to decode incoming message: %s\nLine: %s"
252
-
(Jsont.Error.to_string err) line);
253
-
loop ()
254
-
with
255
-
| exn ->
256
-
Log.err (fun m -> m "Failed to parse message: %s\nLine: %s"
257
-
(Printexc.to_string exn) line);
258
-
loop ()
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 ()
259
186
in
260
187
Log.debug (fun m -> m "Starting message handler");
261
188
loop
···
304
231
Log.debug (fun m -> m "Registered callback: %s for event: %s" callback_id event_name);
305
232
callback_id
306
233
) matcher.Hooks.callbacks in
307
-
json_dict [
234
+
json_object [
308
235
"matcher", (match matcher.Hooks.matcher with
309
236
| Some p -> json_string p
310
-
| None -> json_null);
311
-
"hookCallbackIds", Jsont.Array (List.map (fun id -> json_string id) callback_ids, Jsont.Meta.none);
237
+
| None -> json_null ());
238
+
"hookCallbackIds", Jsont.Json.list (List.map (fun id -> json_string id) callback_ids);
312
239
]
313
240
) matchers in
314
-
(event_name, Jsont.Array (matchers_json, Jsont.Meta.none)) :: acc
241
+
(event_name, Jsont.Json.list matchers_json) :: acc
315
242
) [] hooks_config in
316
243
317
244
(* Send initialize control request *)
318
-
let initialize_msg = json_dict [
245
+
let initialize_msg = json_object [
319
246
"type", json_string "control_request";
320
247
"request_id", json_string "init_hooks";
321
-
"request", json_dict [
248
+
"request", json_object [
322
249
"subtype", json_string "initialize";
323
-
"hooks", json_dict hooks_json;
250
+
"hooks", json_object hooks_json;
324
251
]
325
252
] in
326
253
Log.info (fun m -> m "Sending hooks initialize request");
···
420
347
let response_json = wait_for_response () in
421
348
Log.debug (fun m -> m "Received control response: %s" (json_to_string response_json));
422
349
423
-
(* Parse the response *)
424
-
let response_data = find response_json ["response"] in
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
425
359
let response = match Jsont.Json.decode Sdk_control.Response.jsont response_data with
426
360
| Ok r -> r
427
361
| Error msg -> raise (Invalid_argument ("Failed to decode response: " ^ msg))
+19
-38
claudeio/lib/content_block.ml
+19
-38
claudeio/lib/content_block.ml
···
47
47
48
48
module Tool_use = struct
49
49
module Input = struct
50
+
(* Dynamic JSON data for tool inputs with typed accessors using jsont decoders *)
50
51
type t = Jsont.json
51
52
52
53
let jsont = Jsont.json
53
54
54
55
let of_string_pairs pairs =
55
-
Jsont.Object (
56
-
List.map (fun (k, v) ->
57
-
((Jsont.Json.name k), Jsont.String (v, Jsont.Meta.none))
58
-
) pairs,
59
-
Jsont.Meta.none
60
-
)
56
+
Jsont.Json.object' (List.map (fun (k, v) ->
57
+
Jsont.Json.mem (Jsont.Json.name k) (Jsont.Json.string v)
58
+
) pairs)
61
59
62
60
let of_assoc (assoc : (string * Jsont.json) list) : t =
63
-
Jsont.Object (
64
-
List.map (fun (k, v) -> (Jsont.Json.name k, v)) assoc,
65
-
Jsont.Meta.none
66
-
)
61
+
Jsont.Json.object' (List.map (fun (k, v) -> Jsont.Json.mem (Jsont.Json.name k) v) assoc)
67
62
68
-
let get_field t key =
69
-
match t with
70
-
| Jsont.Object (members, _) ->
71
-
List.find_map (fun ((name, _), value) ->
72
-
if name = key then Some value else None
73
-
) members
74
-
| _ -> None
75
-
76
-
let get_string t key =
77
-
match get_field t key with
78
-
| Some (Jsont.String (s, _)) -> Some s
79
-
| _ -> None
80
-
81
-
let get_int t key =
82
-
match get_field t key with
83
-
| Some (Jsont.Number (f, _)) ->
84
-
let i = int_of_float f in
85
-
if float_of_int i = f then Some i else None
86
-
| _ -> None
63
+
(* Helper to decode an optional field with a given codec *)
64
+
let get_opt (type a) (codec : a Jsont.t) t key : a option =
65
+
let field_codec = Jsont.Object.map ~kind:"field" (fun v -> v)
66
+
|> Jsont.Object.opt_mem key codec ~enc:Fun.id
67
+
|> Jsont.Object.finish
68
+
in
69
+
match Jsont.Json.decode field_codec t with
70
+
| Ok v -> v
71
+
| Error _ -> None
87
72
88
-
let get_bool t key =
89
-
match get_field t key with
90
-
| Some (Jsont.Bool (b, _)) -> Some b
91
-
| _ -> None
92
-
93
-
let get_float t key =
94
-
match get_field t key with
95
-
| Some (Jsont.Number (f, _)) -> Some f
96
-
| _ -> None
73
+
let get_string t key = get_opt Jsont.string t key
74
+
let get_int t key = get_opt Jsont.int t key
75
+
let get_bool t key = get_opt Jsont.bool t key
76
+
let get_float t key = get_opt Jsont.number t key
97
77
98
78
let keys t =
79
+
(* Decode as object with all members captured as unknown *)
99
80
match t with
100
81
| Jsont.Object (members, _) -> List.map (fun ((name, _), _) -> name) members
101
82
| _ -> []
+25
-166
claudeio/lib/hooks.ml
+25
-166
claudeio/lib/hooks.ml
···
117
117
unknown : Input_unknown.t;
118
118
}
119
119
120
-
let get_field json key =
121
-
match json with
122
-
| Jsont.Object (members, _) ->
123
-
List.find_map (fun ((name, _), value) ->
124
-
if name = key then Some value else None
125
-
) members
126
-
| _ -> None
127
-
128
-
let get_string json key =
129
-
match get_field json key with
130
-
| Some (Jsont.String (s, _)) -> Some s
131
-
| _ -> None
132
-
133
-
let of_json json =
134
-
match get_string json "session_id" with
135
-
| None -> raise (Invalid_argument "PreToolUse: missing session_id")
136
-
| Some session_id ->
137
-
match get_string json "transcript_path" with
138
-
| None -> raise (Invalid_argument "PreToolUse: missing transcript_path")
139
-
| Some transcript_path ->
140
-
match get_string json "tool_name" with
141
-
| None -> raise (Invalid_argument "PreToolUse: missing tool_name")
142
-
| Some tool_name ->
143
-
match get_field json "tool_input" with
144
-
| None -> raise (Invalid_argument "PreToolUse: missing tool_input")
145
-
| Some tool_input ->
146
-
{ session_id; transcript_path; tool_name; tool_input; unknown = json }
147
-
148
120
type t = input
149
121
150
122
let session_id t = t.session_id
···
164
136
|> Jsont.Object.mem "tool_input" Jsont.json ~enc:tool_input
165
137
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
166
138
|> Jsont.Object.finish
139
+
140
+
let of_json json =
141
+
match Jsont.Json.decode input_jsont json with
142
+
| Ok v -> v
143
+
| Error msg -> raise (Invalid_argument ("PreToolUse: " ^ msg))
167
144
168
145
type permission_decision = [ `Allow | `Deny | `Ask ]
169
146
···
239
216
unknown : Input_unknown.t;
240
217
}
241
218
242
-
let get_field json key =
243
-
match json with
244
-
| Jsont.Object (members, _) ->
245
-
List.find_map (fun ((name, _), value) ->
246
-
if name = key then Some value else None
247
-
) members
248
-
| _ -> None
249
-
250
-
let get_string json key =
251
-
match get_field json key with
252
-
| Some (Jsont.String (s, _)) -> Some s
253
-
| _ -> None
254
-
255
-
let of_json json =
256
-
match get_string json "session_id" with
257
-
| None -> raise (Invalid_argument "PostToolUse: missing session_id")
258
-
| Some session_id ->
259
-
match get_string json "transcript_path" with
260
-
| None -> raise (Invalid_argument "PostToolUse: missing transcript_path")
261
-
| Some transcript_path ->
262
-
match get_string json "tool_name" with
263
-
| None -> raise (Invalid_argument "PostToolUse: missing tool_name")
264
-
| Some tool_name ->
265
-
match get_field json "tool_input" with
266
-
| None -> raise (Invalid_argument "PostToolUse: missing tool_input")
267
-
| Some tool_input ->
268
-
match get_field json "tool_response" with
269
-
| None -> raise (Invalid_argument "PostToolUse: missing tool_response")
270
-
| Some tool_response ->
271
-
{ session_id; transcript_path; tool_name; tool_input; tool_response; unknown = json }
272
-
273
219
type t = input
274
220
275
221
let session_id t = t.session_id
···
291
237
|> Jsont.Object.mem "tool_response" Jsont.json ~enc:tool_response
292
238
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
293
239
|> Jsont.Object.finish
240
+
241
+
let of_json json =
242
+
match Jsont.Json.decode input_jsont json with
243
+
| Ok v -> v
244
+
| Error msg -> raise (Invalid_argument ("PostToolUse: " ^ msg))
294
245
295
246
module Output_unknown = struct
296
247
type t = Jsont.json
···
345
296
unknown : Input_unknown.t;
346
297
}
347
298
348
-
let get_field json key =
349
-
match json with
350
-
| Jsont.Object (members, _) ->
351
-
List.find_map (fun ((name, _), value) ->
352
-
if name = key then Some value else None
353
-
) members
354
-
| _ -> None
355
-
356
-
let get_string json key =
357
-
match get_field json key with
358
-
| Some (Jsont.String (s, _)) -> Some s
359
-
| _ -> None
360
-
361
-
let of_json json =
362
-
match get_string json "session_id" with
363
-
| None -> raise (Invalid_argument "UserPromptSubmit: missing session_id")
364
-
| Some session_id ->
365
-
match get_string json "transcript_path" with
366
-
| None -> raise (Invalid_argument "UserPromptSubmit: missing transcript_path")
367
-
| Some transcript_path ->
368
-
match get_string json "prompt" with
369
-
| None -> raise (Invalid_argument "UserPromptSubmit: missing prompt")
370
-
| Some prompt ->
371
-
{ session_id; transcript_path; prompt; unknown = json }
372
-
373
299
type t = input
374
300
375
301
let session_id t = t.session_id
···
388
314
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
389
315
|> Jsont.Object.finish
390
316
317
+
let of_json json =
318
+
match Jsont.Json.decode input_jsont json with
319
+
| Ok v -> v
320
+
| Error msg -> raise (Invalid_argument ("UserPromptSubmit: " ^ msg))
321
+
391
322
module Output_unknown = struct
392
323
type t = Jsont.json
393
324
let empty = Jsont.Object ([], Jsont.Meta.none)
···
441
372
unknown : Input_unknown.t;
442
373
}
443
374
444
-
let get_field json key =
445
-
match json with
446
-
| Jsont.Object (members, _) ->
447
-
List.find_map (fun ((name, _), value) ->
448
-
if name = key then Some value else None
449
-
) members
450
-
| _ -> None
451
-
452
-
let get_string json key =
453
-
match get_field json key with
454
-
| Some (Jsont.String (s, _)) -> Some s
455
-
| _ -> None
456
-
457
-
let get_bool json key =
458
-
match get_field json key with
459
-
| Some (Jsont.Bool (b, _)) -> Some b
460
-
| _ -> None
461
-
462
-
let of_json json =
463
-
match get_string json "session_id" with
464
-
| None -> raise (Invalid_argument "Stop: missing session_id")
465
-
| Some session_id ->
466
-
match get_string json "transcript_path" with
467
-
| None -> raise (Invalid_argument "Stop: missing transcript_path")
468
-
| Some transcript_path ->
469
-
match get_bool json "stop_hook_active" with
470
-
| None -> raise (Invalid_argument "Stop: missing stop_hook_active")
471
-
| Some stop_hook_active ->
472
-
{ session_id; transcript_path; stop_hook_active; unknown = json }
473
-
474
375
type t = input
475
376
476
377
let session_id t = t.session_id
···
488
389
|> Jsont.Object.mem "stop_hook_active" Jsont.bool ~enc:stop_hook_active
489
390
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
490
391
|> Jsont.Object.finish
392
+
393
+
let of_json json =
394
+
match Jsont.Json.decode input_jsont json with
395
+
| Ok v -> v
396
+
| Error msg -> raise (Invalid_argument ("Stop: " ^ msg))
491
397
492
398
module Output_unknown = struct
493
399
type t = Jsont.json
···
524
430
(** {1 SubagentStop Hook} - Same structure as Stop *)
525
431
module SubagentStop = struct
526
432
include Stop
527
-
528
-
let get_field json key =
529
-
match json with
530
-
| Jsont.Object (members, _) ->
531
-
List.find_map (fun ((name, _), value) ->
532
-
if name = key then Some value else None
533
-
) members
534
-
| _ -> None
535
-
536
-
let get_string json key =
537
-
match get_field json key with
538
-
| Some (Jsont.String (s, _)) -> Some s
539
-
| _ -> None
540
-
541
-
let get_bool json key =
542
-
match get_field json key with
543
-
| Some (Jsont.Bool (b, _)) -> Some b
544
-
| _ -> None
545
-
546
-
let of_json json =
547
-
match get_string json "session_id" with
548
-
| None -> raise (Invalid_argument "SubagentStop: missing session_id")
549
-
| Some session_id ->
550
-
match get_string json "transcript_path" with
551
-
| None -> raise (Invalid_argument "SubagentStop: missing transcript_path")
552
-
| Some transcript_path ->
553
-
match get_bool json "stop_hook_active" with
554
-
| None -> raise (Invalid_argument "SubagentStop: missing stop_hook_active")
555
-
| Some stop_hook_active ->
556
-
{ session_id; transcript_path; stop_hook_active; unknown = json }
557
433
end
558
434
559
435
(** {1 PreCompact Hook} *)
···
571
447
unknown : Input_unknown.t;
572
448
}
573
449
574
-
let get_field json key =
575
-
match json with
576
-
| Jsont.Object (members, _) ->
577
-
List.find_map (fun ((name, _), value) ->
578
-
if name = key then Some value else None
579
-
) members
580
-
| _ -> None
581
-
582
-
let get_string json key =
583
-
match get_field json key with
584
-
| Some (Jsont.String (s, _)) -> Some s
585
-
| _ -> None
586
-
587
-
let of_json json =
588
-
match get_string json "session_id" with
589
-
| None -> raise (Invalid_argument "PreCompact: missing session_id")
590
-
| Some session_id ->
591
-
match get_string json "transcript_path" with
592
-
| None -> raise (Invalid_argument "PreCompact: missing transcript_path")
593
-
| Some transcript_path ->
594
-
{ session_id; transcript_path; unknown = json }
595
-
596
450
type t = input
597
451
598
452
let session_id t = t.session_id
···
608
462
|> Jsont.Object.mem "transcript_path" Jsont.string ~enc:transcript_path
609
463
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
610
464
|> Jsont.Object.finish
465
+
466
+
let of_json json =
467
+
match Jsont.Json.decode input_jsont json with
468
+
| Ok v -> v
469
+
| Error msg -> raise (Invalid_argument ("PreCompact: " ^ msg))
611
470
612
471
type output = unit (* No specific output for PreCompact *)
613
472
+151
-18
claudeio/lib/incoming.ml
+151
-18
claudeio/lib/incoming.ml
···
1
1
let src = Logs.Src.create "claude.incoming" ~doc:"Incoming messages from Claude CLI"
2
2
module Log = (val Logs.src_log src : Logs.LOG)
3
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
+
4
125
type t =
5
126
| Message of Message.t
6
127
| Control_response of Sdk_control.control_response
128
+
| Control_request of Control_request.t
7
129
8
130
let jsont : t Jsont.t =
9
131
(* Custom decoder that checks the type field and dispatches to the appropriate codec.
10
132
11
133
The challenge is that Message can have multiple type values ("user", "assistant",
12
-
"system", "result"), while control_response has only one type value. Jsont's
13
-
case_mem discriminator doesn't support multiple tags per case, so we implement
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
14
136
a custom decoder/encoder. *)
15
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
+
16
143
let dec json =
17
-
(* First check if it has a type field *)
18
-
match json with
19
-
| Jsont.Object (members, _meta) ->
20
-
let type_field = List.find_map (fun ((name, _), value) ->
21
-
if name = "type" then
22
-
match value with
23
-
| Jsont.String (s, _) -> Some s
24
-
| _ -> None
25
-
else None
26
-
) members in
27
-
(match type_field with
28
-
| Some "control_response" ->
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" ->
29
153
(match Jsont.Json.decode Sdk_control.control_response_jsont json with
30
154
| Ok resp -> Control_response resp
31
155
| Error err -> failwith ("Failed to decode control_response: " ^ err))
32
-
| Some ("user" | "assistant" | "system" | "result") | Some _ | None ->
33
-
(* Try to decode as message *)
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 *)
34
162
(match Jsont.Json.decode Message.jsont json with
35
163
| Ok msg -> Message msg
36
-
| Error err -> failwith ("Failed to decode message: " ^ err)))
37
-
| _ -> failwith "Expected JSON object for incoming message"
164
+
| Error err -> failwith ("Failed to decode message: " ^ err))
38
165
in
39
166
40
167
let enc = function
···
46
173
(match Jsont.Json.encode Sdk_control.control_response_jsont resp with
47
174
| Ok json -> json
48
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))
49
180
in
50
181
51
182
Jsont.map ~kind:"Incoming" ~dec ~enc Jsont.json
···
53
184
let pp fmt = function
54
185
| Message msg -> Format.fprintf fmt "@[<2>Message@ %a@]" Message.pp msg
55
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)
+39
-1
claudeio/lib/incoming.mli
+39
-1
claudeio/lib/incoming.mli
···
6
6
The codec uses the "type" field to discriminate between message types:
7
7
- "user", "assistant", "system", "result" -> Message variant
8
8
- "control_response" -> Control_response variant
9
-
- "control_request" is handled separately in the client (not incoming to SDK user)
9
+
- "control_request" -> Control_request variant
10
10
11
11
This provides a clean, type-safe way to decode incoming messages in a single
12
12
operation, avoiding the parse-then-switch-then-parse pattern. *)
13
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
+
14
51
type t =
15
52
| Message of Message.t
16
53
| Control_response of Sdk_control.control_response
54
+
| Control_request of Control_request.t
17
55
18
56
val jsont : t Jsont.t
19
57
(** Codec for incoming messages. Uses the "type" field to discriminate. *)
+261
-233
claudeio/lib/message.ml
+261
-233
claudeio/lib/message.ml
···
91
91
], Jsont.Meta.none));
92
92
], Jsont.Meta.none)
93
93
94
+
(* Jsont codec for parsing incoming user messages from CLI *)
95
+
let incoming_jsont : t Jsont.t =
96
+
let message_jsont =
97
+
Jsont.Object.map ~kind:"UserMessage" (fun json_content ->
98
+
let content = decode_content json_content in
99
+
{ content; unknown = Unknown.empty }
100
+
)
101
+
|> Jsont.Object.mem "content" Jsont.json ~enc:(fun t -> encode_content (content t))
102
+
|> Jsont.Object.finish
103
+
in
104
+
Jsont.Object.map ~kind:"UserEnvelope" Fun.id
105
+
|> Jsont.Object.mem "message" message_jsont ~enc:Fun.id
106
+
|> Jsont.Object.finish
107
+
94
108
let of_json json =
95
-
match json with
96
-
| Jsont.Object (fields, _) ->
97
-
let message = List.assoc (Jsont.Json.name "message") fields in
98
-
let content = match message with
99
-
| Jsont.Object (msg_fields, _) ->
100
-
(match List.assoc (Jsont.Json.name "content") msg_fields with
101
-
| Jsont.String (s, _) -> String s
102
-
| Jsont.Array (items, _) ->
103
-
Blocks (List.map Content_block.of_json items)
104
-
| _ -> raise (Invalid_argument "User.of_json: invalid content"))
105
-
| _ -> raise (Invalid_argument "User.of_json: invalid message")
106
-
in
107
-
{ content; unknown = Unknown.empty }
108
-
| _ -> raise (Invalid_argument "User.of_json: expected object")
109
+
match Jsont.Json.decode incoming_jsont json with
110
+
| Ok v -> v
111
+
| Error msg -> raise (Invalid_argument ("User.of_json: " ^ msg))
109
112
110
113
let pp fmt t =
111
114
match t.content with
···
240
243
(Jsont.Json.name "message", Jsont.Object (msg_fields, Jsont.Meta.none));
241
244
], Jsont.Meta.none)
242
245
246
+
(* Jsont codec for parsing incoming assistant messages from CLI *)
247
+
let incoming_jsont : t Jsont.t =
248
+
Jsont.Object.map ~kind:"AssistantEnvelope" Fun.id
249
+
|> Jsont.Object.mem "message" jsont ~enc:Fun.id
250
+
|> Jsont.Object.finish
251
+
243
252
let of_json json =
244
-
match json with
245
-
| Jsont.Object (fields, _) ->
246
-
let message = List.assoc (Jsont.Json.name "message") fields in
247
-
let content, model, error = match message with
248
-
| Jsont.Object (msg_fields, _) ->
249
-
let content =
250
-
match List.assoc (Jsont.Json.name "content") msg_fields with
251
-
| Jsont.Array (items, _) -> List.map Content_block.of_json items
252
-
| _ -> raise (Invalid_argument "Assistant.of_json: invalid content")
253
-
in
254
-
let model = match List.assoc (Jsont.Json.name "model") msg_fields with
255
-
| Jsont.String (s, _) -> s
256
-
| _ -> raise (Invalid_argument "Assistant.of_json: invalid model")
257
-
in
258
-
let error =
259
-
match List.assoc_opt (Jsont.Json.name "error") msg_fields with
260
-
| Some (Jsont.String (err_str, _)) -> Some (error_of_string err_str)
261
-
| Some _ -> raise (Invalid_argument "Assistant.of_json: invalid error")
262
-
| None -> None
263
-
in
264
-
content, model, error
265
-
| _ -> raise (Invalid_argument "Assistant.of_json: invalid message")
266
-
in
267
-
{ content; model; error; unknown = Unknown.empty }
268
-
| _ -> raise (Invalid_argument "Assistant.of_json: expected object")
253
+
match Jsont.Json.decode incoming_jsont json with
254
+
| Ok v -> v
255
+
| Error msg -> raise (Invalid_argument ("Assistant.of_json: " ^ msg))
269
256
270
257
let pp fmt t =
271
258
let text_count = List.length (get_text_blocks t) in
···
300
287
end
301
288
302
289
module System = struct
303
-
module Data = struct
304
-
(* Opaque JSON type with typed accessors *)
305
-
type t = Jsont.json
290
+
(** Typed data for system init messages *)
291
+
module Init = struct
292
+
module Unknown = struct
293
+
type t = Jsont.json
294
+
let empty = Jsont.Object ([], Jsont.Meta.none)
295
+
let _jsont = Jsont.json
296
+
end
297
+
298
+
type t = {
299
+
session_id : string option;
300
+
model : string option;
301
+
cwd : string option;
302
+
unknown : Unknown.t;
303
+
}
304
+
305
+
let make session_id model cwd unknown = { session_id; model; cwd; unknown }
306
306
307
-
let jsont = Jsont.json
307
+
let create ?session_id ?model ?cwd () =
308
+
{ session_id; model; cwd; unknown = Unknown.empty }
309
+
310
+
let session_id t = t.session_id
311
+
let model t = t.model
312
+
let cwd t = t.cwd
313
+
let unknown t = t.unknown
308
314
309
-
let empty = Jsont.Object ([], Jsont.Meta.none)
315
+
let jsont : t Jsont.t =
316
+
Jsont.Object.map ~kind:"SystemInit" make
317
+
|> Jsont.Object.opt_mem "session_id" Jsont.string ~enc:session_id
318
+
|> Jsont.Object.opt_mem "model" Jsont.string ~enc:model
319
+
|> Jsont.Object.opt_mem "cwd" Jsont.string ~enc:cwd
320
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
321
+
|> Jsont.Object.finish
322
+
end
310
323
311
-
let of_assoc (assoc : (string * Jsont.json) list) : t =
312
-
Jsont.Object (
313
-
List.map (fun (k, v) -> (Jsont.Json.name k, v)) assoc,
314
-
Jsont.Meta.none
315
-
)
324
+
(** Typed data for system error messages *)
325
+
module Error = struct
326
+
module Unknown = struct
327
+
type t = Jsont.json
328
+
let empty = Jsont.Object ([], Jsont.Meta.none)
329
+
let _jsont = Jsont.json
330
+
end
331
+
332
+
type t = {
333
+
error : string;
334
+
unknown : Unknown.t;
335
+
}
336
+
337
+
let make error unknown = { error; unknown }
338
+
339
+
let create ~error = { error; unknown = Unknown.empty }
340
+
341
+
let error t = t.error
342
+
let unknown t = t.unknown
343
+
344
+
let jsont : t Jsont.t =
345
+
Jsont.Object.map ~kind:"SystemError" make
346
+
|> Jsont.Object.mem "error" Jsont.string ~enc:error
347
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
348
+
|> Jsont.Object.finish
349
+
end
316
350
317
-
let get_field t key =
318
-
match t with
319
-
| Jsont.Object (members, _) ->
320
-
List.find_map (fun ((name, _), value) ->
321
-
if name = key then Some value else None
322
-
) members
323
-
| _ -> None
351
+
(** Sum type for system message data *)
352
+
module Data = struct
353
+
type t =
354
+
| Init of Init.t
355
+
| Error of Error.t
356
+
| Other of Jsont.json (** Unknown subtypes preserve raw JSON *)
324
357
325
-
let get_string t key =
326
-
match get_field t key with
327
-
| Some (Jsont.String (s, _)) -> Some s
328
-
| _ -> None
358
+
let init ?session_id ?model ?cwd () = Init (Init.create ?session_id ?model ?cwd ())
359
+
let error ~error = Error (Error.create ~error)
360
+
let other json = Other json
329
361
330
-
let get_int t key =
331
-
match get_field t key with
332
-
| Some (Jsont.Number (f, _)) ->
333
-
let i = int_of_float f in
334
-
if float_of_int i = f then Some i else None
362
+
let session_id = function
363
+
| Init i -> Init.session_id i
335
364
| _ -> None
336
365
337
-
let get_bool t key =
338
-
match get_field t key with
339
-
| Some (Jsont.Bool (b, _)) -> Some b
366
+
let model = function
367
+
| Init i -> Init.model i
340
368
| _ -> None
341
369
342
-
let get_float t key =
343
-
match get_field t key with
344
-
| Some (Jsont.Number (f, _)) -> Some f
370
+
let cwd = function
371
+
| Init i -> Init.cwd i
345
372
| _ -> None
346
373
347
-
let get_list t key =
348
-
match get_field t key with
349
-
| Some (Jsont.Array (items, _)) -> Some items
374
+
let error_msg = function
375
+
| Error e -> Some (Error.error e)
350
376
| _ -> None
351
377
352
-
let raw_json t = t
378
+
let to_json = function
379
+
| Init i ->
380
+
(match Jsont.Json.encode Init.jsont i with
381
+
| Ok json -> json
382
+
| Error msg -> failwith ("Init.to_json: " ^ msg))
383
+
| Error e ->
384
+
(match Jsont.Json.encode Error.jsont e with
385
+
| Ok json -> json
386
+
| Error msg -> failwith ("Error.to_json: " ^ msg))
387
+
| Other json -> json
353
388
354
-
let to_json t = t
355
-
let of_json json = json
389
+
let of_json ~subtype json =
390
+
match subtype with
391
+
| "init" ->
392
+
(match Jsont.Json.decode Init.jsont json with
393
+
| Ok i -> Init i
394
+
| Error _ -> Other json)
395
+
| "error" ->
396
+
(match Jsont.Json.decode Error.jsont json with
397
+
| Ok e -> Error e
398
+
| Error _ -> Other json)
399
+
| _ -> Other json
356
400
end
357
401
358
402
module Unknown = struct
···
369
413
}
370
414
371
415
let create ~subtype ~data = { subtype; data; unknown = Unknown.empty }
372
-
let make subtype data unknown = { subtype; data; unknown }
373
416
let subtype t = t.subtype
374
417
let data t = t.data
375
418
let unknown t = t.unknown
376
419
420
+
(** Create a system init message *)
421
+
let init ?session_id ?model ?cwd () =
422
+
{ subtype = "init";
423
+
data = Data.init ?session_id ?model ?cwd ();
424
+
unknown = Unknown.empty }
425
+
426
+
(** Create a system error message *)
427
+
let error ~error =
428
+
{ subtype = "error";
429
+
data = Data.error ~error;
430
+
unknown = Unknown.empty }
431
+
377
432
(* Custom jsont that handles both formats:
378
433
- Old format: {"type":"system","subtype":"init","data":{...}}
379
434
- New format: {"type":"system","subtype":"init","cwd":"...","session_id":"...",...}
380
435
When data field is not present, we use the entire object as data *)
381
436
let jsont : t Jsont.t =
382
-
let make_with_optional_data subtype opt_data unknown_json =
383
-
let data = match opt_data with
384
-
| Some d -> d
385
-
| None -> unknown_json (* Use the full unknown object as data *)
437
+
let dec json =
438
+
(* First decode just the subtype *)
439
+
let subtype_codec = Jsont.Object.map ~kind:"SystemSubtype" Fun.id
440
+
|> Jsont.Object.mem "subtype" Jsont.string ~enc:Fun.id
441
+
|> Jsont.Object.finish
386
442
in
387
-
make subtype data Unknown.empty
443
+
match Jsont.Json.decode subtype_codec json with
444
+
| Error msg -> failwith ("System.jsont: " ^ msg)
445
+
| Ok subtype ->
446
+
(* Try to get data field, otherwise use full object *)
447
+
let data_codec = Jsont.Object.map ~kind:"SystemDataField" Fun.id
448
+
|> Jsont.Object.opt_mem "data" Jsont.json ~enc:Fun.id
449
+
|> Jsont.Object.finish
450
+
in
451
+
let data_json = match Jsont.Json.decode data_codec json with
452
+
| Ok (Some d) -> d
453
+
| _ -> json
454
+
in
455
+
let data = Data.of_json ~subtype data_json in
456
+
{ subtype; data; unknown = Unknown.empty }
388
457
in
389
-
Jsont.Object.map ~kind:"System" make_with_optional_data
390
-
|> Jsont.Object.mem "subtype" Jsont.string ~enc:subtype
391
-
|> Jsont.Object.opt_mem "data" Data.jsont ~enc:(fun t -> Some (data t))
392
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun _ -> Unknown.empty)
393
-
|> Jsont.Object.finish
458
+
let enc t =
459
+
Jsont.Json.object' [
460
+
Jsont.Json.mem (Jsont.Json.name "type") (Jsont.Json.string "system");
461
+
Jsont.Json.mem (Jsont.Json.name "subtype") (Jsont.Json.string t.subtype);
462
+
Jsont.Json.mem (Jsont.Json.name "data") (Data.to_json t.data);
463
+
]
464
+
in
465
+
Jsont.map ~kind:"System" ~dec ~enc Jsont.json
394
466
395
467
let to_json t =
396
-
Jsont.Object ([
397
-
(Jsont.Json.name "type", Jsont.String ("system", Jsont.Meta.none));
398
-
(Jsont.Json.name "subtype", Jsont.String (t.subtype, Jsont.Meta.none));
399
-
(Jsont.Json.name "data", Data.to_json t.data);
400
-
], Jsont.Meta.none)
468
+
match Jsont.Json.encode jsont t with
469
+
| Ok json -> json
470
+
| Error msg -> failwith ("System.to_json: " ^ msg)
401
471
402
472
let of_json json =
403
-
match json with
404
-
| Jsont.Object (fields, _) ->
405
-
let subtype = match List.assoc (Jsont.Json.name "subtype") fields with
406
-
| Jsont.String (s, _) -> s
407
-
| _ -> raise (Invalid_argument "System.of_json: invalid subtype")
408
-
in
409
-
let data = Data.of_json (
410
-
try List.assoc (Jsont.Json.name "data") fields
411
-
with Not_found -> Jsont.Object (fields, Jsont.Meta.none)
412
-
) in
413
-
{ subtype; data; unknown = Unknown.empty }
414
-
| _ -> raise (Invalid_argument "System.of_json: expected object")
473
+
match Jsont.Json.decode jsont json with
474
+
| Ok v -> v
475
+
| Error msg -> raise (Invalid_argument ("System.of_json: " ^ msg))
415
476
416
477
let pp fmt t =
417
-
match t.subtype with
418
-
| "init" ->
419
-
let session_id = Data.get_string t.data "session_id" in
420
-
let model = Data.get_string t.data "model" in
421
-
let cwd = Data.get_string t.data "cwd" in
478
+
match t.data with
479
+
| Data.Init i ->
422
480
Fmt.pf fmt "@[<2>System.init@ { session_id = %a;@ model = %a;@ cwd = %a }@]"
423
-
Fmt.(option string) session_id
424
-
Fmt.(option string) model
425
-
Fmt.(option string) cwd
426
-
| "error" ->
427
-
let error = Data.get_string t.data "error" in
428
-
Fmt.pf fmt "@[<2>System.error@ { error = %a }@]"
429
-
Fmt.(option string) error
430
-
| _ ->
481
+
Fmt.(option string) (Init.session_id i)
482
+
Fmt.(option string) (Init.model i)
483
+
Fmt.(option string) (Init.cwd i)
484
+
| Data.Error e ->
485
+
Fmt.pf fmt "@[<2>System.error@ { error = %s }@]" (Error.error e)
486
+
| Data.Other _ ->
431
487
Fmt.pf fmt "@[<2>System.%s@ { ... }@]" t.subtype
432
488
end
433
489
434
490
module Result = struct
435
491
module Usage = struct
436
-
(* Opaque JSON type with typed accessors *)
437
-
type t = Jsont.json
492
+
module Unknown = struct
493
+
type t = Jsont.json
494
+
let empty = Jsont.Object ([], Jsont.Meta.none)
495
+
let is_empty = function Jsont.Object ([], _) -> true | _ -> false
496
+
let jsont = Jsont.json
497
+
end
438
498
439
-
let jsont = Jsont.json
499
+
type t = {
500
+
input_tokens : int option;
501
+
output_tokens : int option;
502
+
total_tokens : int option;
503
+
cache_creation_input_tokens : int option;
504
+
cache_read_input_tokens : int option;
505
+
unknown : Unknown.t;
506
+
}
507
+
508
+
let make input_tokens output_tokens total_tokens
509
+
cache_creation_input_tokens cache_read_input_tokens unknown =
510
+
{ input_tokens; output_tokens; total_tokens;
511
+
cache_creation_input_tokens; cache_read_input_tokens; unknown }
440
512
441
513
let create ?input_tokens ?output_tokens ?total_tokens
442
514
?cache_creation_input_tokens ?cache_read_input_tokens () =
443
-
let fields = [] in
444
-
let fields = match input_tokens with
445
-
| Some n -> (Jsont.Json.name "input_tokens", Jsont.Number (float_of_int n, Jsont.Meta.none)) :: fields
446
-
| None -> fields in
447
-
let fields = match output_tokens with
448
-
| Some n -> (Jsont.Json.name "output_tokens", Jsont.Number (float_of_int n, Jsont.Meta.none)) :: fields
449
-
| None -> fields in
450
-
let fields = match total_tokens with
451
-
| Some n -> (Jsont.Json.name "total_tokens", Jsont.Number (float_of_int n, Jsont.Meta.none)) :: fields
452
-
| None -> fields in
453
-
let fields = match cache_creation_input_tokens with
454
-
| Some n -> (Jsont.Json.name "cache_creation_input_tokens", Jsont.Number (float_of_int n, Jsont.Meta.none)) :: fields
455
-
| None -> fields in
456
-
let fields = match cache_read_input_tokens with
457
-
| Some n -> (Jsont.Json.name "cache_read_input_tokens", Jsont.Number (float_of_int n, Jsont.Meta.none)) :: fields
458
-
| None -> fields in
459
-
Jsont.Object (fields, Jsont.Meta.none)
460
-
461
-
let get_field t key =
462
-
match t with
463
-
| Jsont.Object (members, _) ->
464
-
List.find_map (fun ((name, _), value) ->
465
-
if name = key then Some value else None
466
-
) members
467
-
| _ -> None
468
-
469
-
let get_int t key =
470
-
match get_field t key with
471
-
| Some (Jsont.Number (f, _)) ->
472
-
let i = int_of_float f in
473
-
if float_of_int i = f then Some i else None
474
-
| _ -> None
515
+
{ input_tokens; output_tokens; total_tokens;
516
+
cache_creation_input_tokens; cache_read_input_tokens;
517
+
unknown = Unknown.empty }
475
518
476
-
let input_tokens t = get_int t "input_tokens"
519
+
let input_tokens t = t.input_tokens
520
+
let output_tokens t = t.output_tokens
521
+
let total_tokens t = t.total_tokens
522
+
let cache_creation_input_tokens t = t.cache_creation_input_tokens
523
+
let cache_read_input_tokens t = t.cache_read_input_tokens
524
+
let unknown t = t.unknown
477
525
478
-
let output_tokens t = get_int t "output_tokens"
479
-
480
-
let total_tokens t = get_int t "total_tokens"
481
-
482
-
let cache_creation_input_tokens t = get_int t "cache_creation_input_tokens"
483
-
484
-
let cache_read_input_tokens t = get_int t "cache_read_input_tokens"
526
+
let jsont : t Jsont.t =
527
+
Jsont.Object.map ~kind:"Usage" make
528
+
|> Jsont.Object.opt_mem "input_tokens" Jsont.int ~enc:input_tokens
529
+
|> Jsont.Object.opt_mem "output_tokens" Jsont.int ~enc:output_tokens
530
+
|> Jsont.Object.opt_mem "total_tokens" Jsont.int ~enc:total_tokens
531
+
|> Jsont.Object.opt_mem "cache_creation_input_tokens" Jsont.int ~enc:cache_creation_input_tokens
532
+
|> Jsont.Object.opt_mem "cache_read_input_tokens" Jsont.int ~enc:cache_read_input_tokens
533
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown
534
+
|> Jsont.Object.finish
485
535
486
536
let effective_input_tokens t =
487
-
match input_tokens t with
537
+
match t.input_tokens with
488
538
| None -> 0
489
539
| Some input ->
490
-
let cached = Option.value (cache_read_input_tokens t) ~default:0 in
540
+
let cached = Option.value t.cache_read_input_tokens ~default:0 in
491
541
max 0 (input - cached)
492
542
493
543
let total_cost_estimate t ~input_price ~output_price =
494
-
match input_tokens t, output_tokens t with
544
+
match t.input_tokens, t.output_tokens with
495
545
| Some input, Some output ->
496
546
let input_cost = float_of_int input *. input_price /. 1_000_000. in
497
547
let output_cost = float_of_int output *. output_price /. 1_000_000. in
···
501
551
let pp fmt t =
502
552
Fmt.pf fmt "@[<2>Usage@ { input = %a;@ output = %a;@ total = %a;@ \
503
553
cache_creation = %a;@ cache_read = %a }@]"
504
-
Fmt.(option int) (input_tokens t)
505
-
Fmt.(option int) (output_tokens t)
506
-
Fmt.(option int) (total_tokens t)
507
-
Fmt.(option int) (cache_creation_input_tokens t)
508
-
Fmt.(option int) (cache_read_input_tokens t)
554
+
Fmt.(option int) t.input_tokens
555
+
Fmt.(option int) t.output_tokens
556
+
Fmt.(option int) t.total_tokens
557
+
Fmt.(option int) t.cache_creation_input_tokens
558
+
Fmt.(option int) t.cache_read_input_tokens
509
559
510
-
let to_json t = t
511
-
let of_json json = json
560
+
let to_json t =
561
+
match Jsont.Json.encode jsont t with
562
+
| Ok json -> json
563
+
| Error msg -> failwith ("Usage.to_json: " ^ msg)
564
+
565
+
let of_json json =
566
+
match Jsont.Json.decode jsont json with
567
+
| Ok v -> v
568
+
| Error msg -> raise (Invalid_argument ("Usage.of_json: " ^ msg))
512
569
end
513
570
514
571
module Unknown = struct
···
598
655
Jsont.Object (fields, Jsont.Meta.none)
599
656
600
657
let of_json json =
601
-
match json with
602
-
| Jsont.Object (fields, _) ->
603
-
let subtype = match List.assoc (Jsont.Json.name "subtype") fields with
604
-
| Jsont.String (s, _) -> s
605
-
| _ -> raise (Invalid_argument "Result.of_json: invalid subtype")
606
-
in
607
-
let duration_ms = match List.assoc (Jsont.Json.name "duration_ms") fields with
608
-
| Jsont.Number (f, _) -> int_of_float f
609
-
| _ -> raise (Invalid_argument "Result.of_json: invalid duration_ms")
610
-
in
611
-
let duration_api_ms = match List.assoc (Jsont.Json.name "duration_api_ms") fields with
612
-
| Jsont.Number (f, _) -> int_of_float f
613
-
| _ -> raise (Invalid_argument "Result.of_json: invalid duration_api_ms")
614
-
in
615
-
let is_error = match List.assoc (Jsont.Json.name "is_error") fields with
616
-
| Jsont.Bool (b, _) -> b
617
-
| _ -> raise (Invalid_argument "Result.of_json: invalid is_error")
618
-
in
619
-
let num_turns = match List.assoc (Jsont.Json.name "num_turns") fields with
620
-
| Jsont.Number (f, _) -> int_of_float f
621
-
| _ -> raise (Invalid_argument "Result.of_json: invalid num_turns")
622
-
in
623
-
let session_id = match List.assoc (Jsont.Json.name "session_id") fields with
624
-
| Jsont.String (s, _) -> s
625
-
| _ -> raise (Invalid_argument "Result.of_json: invalid session_id")
626
-
in
627
-
let total_cost_usd = match List.assoc_opt (Jsont.Json.name "total_cost_usd") fields with
628
-
| Some (Jsont.Number (f, _)) -> Some f
629
-
| Some _ -> raise (Invalid_argument "Result.of_json: invalid total_cost_usd")
630
-
| None -> None
631
-
in
632
-
let usage = Option.map Usage.of_json (List.assoc_opt (Jsont.Json.name "usage") fields) in
633
-
let result = match List.assoc_opt (Jsont.Json.name "result") fields with
634
-
| Some (Jsont.String (s, _)) -> Some s
635
-
| Some _ -> raise (Invalid_argument "Result.of_json: invalid result")
636
-
| None -> None
637
-
in
638
-
let structured_output = List.assoc_opt (Jsont.Json.name "structured_output") fields in
639
-
{ subtype; duration_ms; duration_api_ms; is_error; num_turns;
640
-
session_id; total_cost_usd; usage; result; structured_output; unknown = Unknown.empty }
641
-
| _ -> raise (Invalid_argument "Result.of_json: expected object")
658
+
match Jsont.Json.decode jsont json with
659
+
| Ok v -> v
660
+
| Error msg -> raise (Invalid_argument ("Result.of_json: " ^ msg))
642
661
643
662
let pp fmt t =
644
663
if t.is_error then
···
683
702
684
703
let system ~subtype ~data = System (System.create ~subtype ~data)
685
704
let system_init ~session_id =
686
-
let data = System.Data.of_assoc [(("session_id", Jsont.String (session_id, Jsont.Meta.none)))] in
687
-
System (System.create ~subtype:"init" ~data)
705
+
System (System.init ~session_id ())
688
706
let system_error ~error =
689
-
let data = System.Data.of_assoc [(("error", Jsont.String (error, Jsont.Meta.none)))] in
690
-
System (System.create ~subtype:"error" ~data)
707
+
System (System.error ~error)
691
708
692
709
let result ~subtype ~duration_ms ~duration_api_ms ~is_error ~num_turns
693
710
~session_id ?total_cost_usd ?usage ?result ?structured_output () =
···
700
717
| System t -> System.to_json t
701
718
| Result t -> Result.to_json t
702
719
703
-
let of_json json =
704
-
match json with
705
-
| Jsont.Object (fields, _) -> (
706
-
match List.assoc_opt (Jsont.Json.name "type") fields with
707
-
| Some (Jsont.String ("user", _)) -> User (User.of_json json)
708
-
| Some (Jsont.String ("assistant", _)) -> Assistant (Assistant.of_json json)
709
-
| Some (Jsont.String ("system", _)) -> System (System.of_json json)
710
-
| Some (Jsont.String ("result", _)) -> Result (Result.of_json json)
711
-
| Some _ -> raise (Invalid_argument "Message.of_json: invalid type")
712
-
| None -> raise (Invalid_argument "Message.of_json: missing type field")
713
-
)
714
-
| _ -> raise (Invalid_argument "Message.of_json: expected object")
715
-
716
720
(* Jsont codec for the main Message variant type.
717
-
Uses a custom decoder to handle both old and new formats. *)
721
+
Uses case_mem for discriminated union based on "type" field. *)
718
722
let jsont : t Jsont.t =
719
-
Jsont.map ~kind:"Message" ~dec:of_json ~enc:to_json Jsont.json
723
+
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
724
+
let case_user = case_map "user" User.incoming_jsont (fun v -> User v) in
725
+
let case_assistant = case_map "assistant" Assistant.incoming_jsont (fun v -> Assistant v) in
726
+
let case_system = case_map "system" System.jsont (fun v -> System v) in
727
+
let case_result = case_map "result" Result.jsont (fun v -> Result v) in
728
+
let enc_case = function
729
+
| User v -> Jsont.Object.Case.value case_user v
730
+
| Assistant v -> Jsont.Object.Case.value case_assistant v
731
+
| System v -> Jsont.Object.Case.value case_system v
732
+
| Result v -> Jsont.Object.Case.value case_result v
733
+
in
734
+
let cases = Jsont.Object.Case.[
735
+
make case_user;
736
+
make case_assistant;
737
+
make case_system;
738
+
make case_result
739
+
] in
740
+
Jsont.Object.map ~kind:"Message" Fun.id
741
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
742
+
~tag_to_string:Fun.id ~tag_compare:String.compare
743
+
|> Jsont.Object.finish
744
+
745
+
let of_json json =
746
+
match Jsont.Json.decode jsont json with
747
+
| Ok v -> v
748
+
| Error msg -> raise (Invalid_argument ("Message.of_json: " ^ msg))
720
749
721
750
let pp fmt = function
722
751
| User t -> User.pp fmt t
···
746
775
| _ -> []
747
776
748
777
let get_session_id = function
749
-
| System s when System.subtype s = "init" ->
750
-
System.Data.get_string (System.data s) "session_id"
778
+
| System s -> System.Data.session_id (System.data s)
751
779
| Result r -> Some (Result.session_id r)
752
780
| _ -> None
753
781
+73
-29
claudeio/lib/message.mli
+73
-29
claudeio/lib/message.mli
···
154
154
module System : sig
155
155
(** System control and status messages. *)
156
156
157
-
module Data : sig
158
-
(** System message data. *)
157
+
(** Typed data for system init messages *)
158
+
module Init : sig
159
+
type t
160
+
(** Type of init message data. *)
159
161
160
-
type t = Jsont.json
161
-
(** Opaque type for system message data. Contains the raw JSON
162
-
with typed accessors for common fields. *)
162
+
val create : ?session_id:string -> ?model:string -> ?cwd:string -> unit -> t
163
+
(** [create ?session_id ?model ?cwd ()] creates init data. *)
164
+
165
+
val session_id : t -> string option
166
+
(** [session_id t] returns the session ID if present. *)
167
+
168
+
val model : t -> string option
169
+
(** [model t] returns the model name if present. *)
170
+
171
+
val cwd : t -> string option
172
+
(** [cwd t] returns the current working directory if present. *)
163
173
164
174
val jsont : t Jsont.t
165
-
(** [jsont] is the Jsont codec for system data. *)
175
+
(** [jsont] is the Jsont codec for init data. *)
176
+
end
166
177
167
-
val empty : t
168
-
(** [empty] creates empty data. *)
178
+
(** Typed data for system error messages *)
179
+
module Error : sig
180
+
type t
181
+
(** Type of error message data. *)
169
182
170
-
val of_assoc : (string * Jsont.json) list -> t
171
-
(** [of_assoc assoc] creates data from an association list. *)
183
+
val create : error:string -> t
184
+
(** [create ~error] creates error data. *)
172
185
173
-
val get_string : t -> string -> string option
174
-
(** [get_string t key] returns the string value for [key], if present. *)
186
+
val error : t -> string
187
+
(** [error t] returns the error message. *)
175
188
176
-
val get_int : t -> string -> int option
177
-
(** [get_int t key] returns the integer value for [key], if present. *)
189
+
val jsont : t Jsont.t
190
+
(** [jsont] is the Jsont codec for error data. *)
191
+
end
178
192
179
-
val get_bool : t -> string -> bool option
180
-
(** [get_bool t key] returns the boolean value for [key], if present. *)
193
+
(** System message data variants *)
194
+
module Data : sig
195
+
type t =
196
+
| Init of Init.t (** Init message data *)
197
+
| Error of Error.t (** Error message data *)
198
+
| Other of Jsont.json (** Unknown subtype data *)
199
+
(** Variant type for system message data. *)
181
200
182
-
val get_float : t -> string -> float option
183
-
(** [get_float t key] returns the float value for [key], if present. *)
201
+
val init : ?session_id:string -> ?model:string -> ?cwd:string -> unit -> t
202
+
(** [init ?session_id ?model ?cwd ()] creates init data. *)
184
203
185
-
val get_list : t -> string -> Jsont.json list option
186
-
(** [get_list t key] returns the list value for [key], if present. *)
204
+
val error : error:string -> t
205
+
(** [error ~error] creates error data. *)
187
206
188
-
val get_field : t -> string -> Jsont.json option
189
-
(** [get_field t key] returns the raw JSON value for [key], if present. *)
207
+
val other : Jsont.json -> t
208
+
(** [other json] creates data for unknown subtypes. *)
190
209
191
-
val raw_json : t -> Jsont.json
192
-
(** [raw_json t] returns the full underlying JSON data. *)
210
+
val session_id : t -> string option
211
+
(** [session_id t] extracts session_id from Init data, None otherwise. *)
212
+
213
+
val model : t -> string option
214
+
(** [model t] extracts model from Init data, None otherwise. *)
215
+
216
+
val cwd : t -> string option
217
+
(** [cwd t] extracts cwd from Init data, None otherwise. *)
218
+
219
+
val error_msg : t -> string option
220
+
(** [error_msg t] extracts error from Error data, None otherwise. *)
193
221
194
222
val to_json : t -> Jsont.json
195
-
(** [to_json t] converts to JSON representation. Internal use only. *)
223
+
(** [to_json t] converts to JSON representation. *)
196
224
197
-
val of_json : Jsont.json -> t
198
-
(** [of_json json] parses from JSON. Internal use only. *)
225
+
val of_json : subtype:string -> Jsont.json -> t
226
+
(** [of_json ~subtype json] parses data based on subtype. *)
199
227
end
200
228
201
229
module Unknown : sig
···
216
244
@param subtype The subtype of the system message
217
245
@param data Additional data for the message *)
218
246
247
+
val init : ?session_id:string -> ?model:string -> ?cwd:string -> unit -> t
248
+
(** [init ?session_id ?model ?cwd ()] creates a system init message. *)
249
+
250
+
val error : error:string -> t
251
+
(** [error ~error] creates a system error message. *)
252
+
219
253
val subtype : t -> string
220
254
(** [subtype t] returns the subtype of the system message. *)
221
255
···
244
278
module Usage : sig
245
279
(** Usage statistics for API calls. *)
246
280
247
-
type t = Jsont.json
248
-
(** Opaque type for usage statistics. *)
281
+
module Unknown : sig
282
+
type t = Jsont.json
283
+
val empty : t
284
+
val is_empty : t -> bool
285
+
val jsont : t Jsont.t
286
+
end
287
+
288
+
type t
289
+
(** Type for usage statistics. *)
249
290
250
291
val jsont : t Jsont.t
251
292
(** [jsont] is the Jsont codec for usage statistics. *)
···
274
315
275
316
val cache_read_input_tokens : t -> int option
276
317
(** [cache_read_input_tokens t] returns cache read input tokens. *)
318
+
319
+
val unknown : t -> Unknown.t
320
+
(** [unknown t] returns the unknown fields preserved from JSON. *)
277
321
278
322
val effective_input_tokens : t -> int
279
323
(** [effective_input_tokens t] returns input tokens minus cached tokens, or 0 if not available. *)
+11
-10
claudeio/lib/options.ml
+11
-10
claudeio/lib/options.ml
···
203
203
~enc:Model.to_string
204
204
Jsont.string
205
205
206
-
(* Helper codec for env - list of string pairs encoded as object *)
206
+
(* Helper codec for env - list of string pairs encoded as object.
207
+
Env is a dynamic object where all values should be strings.
208
+
Uses pattern matching to extract object members, then jsont for string decoding. *)
207
209
let env_jsont : (string * string) list Jsont.t =
208
210
Jsont.map ~kind:"Env"
209
-
~dec:(fun obj ->
210
-
match obj with
211
+
~dec:(fun json ->
212
+
match json with
211
213
| Jsont.Object (members, _) ->
212
-
List.map (fun ((name, _), value) ->
213
-
match value with
214
-
| Jsont.String (s, _) -> (name, s)
215
-
| _ -> (name, "")
214
+
List.filter_map (fun ((name, _), value) ->
215
+
match Jsont.Json.decode Jsont.string value with
216
+
| Ok s -> Some (name, s)
217
+
| Error _ -> None
216
218
) members
217
219
| _ -> [])
218
220
~enc:(fun pairs ->
219
-
let mems = List.map (fun (k, v) ->
221
+
Jsont.Json.object' (List.map (fun (k, v) ->
220
222
Jsont.Json.mem (Jsont.Json.name k) (Jsont.Json.string v)
221
-
) pairs in
222
-
Jsont.Json.object' mems)
223
+
) pairs))
223
224
Jsont.json
224
225
225
226
(* Helper codec for headers - list of string pairs encoded as object *)
+18
-30
claudeio/test/test_json_utils.ml
+18
-30
claudeio/test/test_json_utils.ml
···
1
-
(* Helper functions for JSON operations in tests *)
1
+
(* Helper functions for JSON operations in tests using jsont codecs *)
2
2
3
3
let to_string ?(minify=false) json =
4
4
let format = if minify then Jsont.Minify else Jsont.Indent in
···
6
6
| Ok s -> s
7
7
| Error err -> Jsont.Error.to_string err
8
8
9
-
let get_field json key =
10
-
match json with
11
-
| Jsont.Object (members, _) ->
12
-
List.find_map (fun ((name, _), value) ->
13
-
if name = key then Some value else None
14
-
) members
15
-
| _ -> None
16
-
17
-
let get_string json key =
18
-
match get_field json key with
19
-
| Some (Jsont.String (s, _)) -> Some s
20
-
| _ -> None
21
-
22
-
let get_int json key =
23
-
match get_field json key with
24
-
| Some (Jsont.Number (f, _)) ->
25
-
let i = int_of_float f in
26
-
if float_of_int i = f then Some i else None
27
-
| _ -> None
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
28
18
29
-
let get_bool json key =
30
-
match get_field json key with
31
-
| Some (Jsont.Bool (b, _)) -> Some b
32
-
| _ -> None
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
33
22
34
23
let get_array json key =
35
-
match get_field json key with
36
-
| Some (Jsont.Array (items, _)) -> Some items
37
-
| _ -> None
24
+
get_opt (Jsont.list Jsont.json) json key
38
25
39
-
let as_string = function
40
-
| Jsont.String (s, _) -> Some s
41
-
| _ -> None
26
+
let as_string json =
27
+
match Jsont.Json.decode Jsont.string json with
28
+
| Ok s -> Some s
29
+
| Error _ -> None