anil.recoil.org
OCaml Claude SDK using Eio and Jsont
sync
+21
-26
lib/client.ml
+21
-26
lib/client.ml
···
91
92
let session_id t = t.session_id
93
94
-
let handle_control_request t (ctrl_req : Incoming.Control_request.t) =
95
-
let request_id = Incoming.Control_request.request_id ctrl_req in
96
-
Log.info (fun m ->
97
-
m "Handling control request: %s"
98
-
(Incoming.Control_request.subtype ctrl_req));
99
100
-
match Incoming.Control_request.request ctrl_req with
101
-
| Incoming.Control_request.Can_use_tool req ->
102
-
let tool_name = Incoming.Control_request.Can_use_tool.tool_name req in
103
-
let input = Incoming.Control_request.Can_use_tool.input req in
104
Log.info (fun m ->
105
m "Permission request for tool '%s' with input: %s" tool_name
106
(json_to_string input));
107
-
(* TODO: Parse permission_suggestions properly *)
108
-
let context = Permissions.Context.create ~suggestions:[] () in
109
110
Log.info (fun m ->
111
m "Invoking permission callback for tool: %s" tool_name);
···
136
Log.info (fun m ->
137
m "Sending control response: %s" (json_to_string response));
138
Transport.send t.transport response
139
-
| Incoming.Control_request.Hook_callback req -> (
140
-
let callback_id =
141
-
Incoming.Control_request.Hook_callback.callback_id req
142
-
in
143
-
let input = Incoming.Control_request.Hook_callback.input req in
144
-
let tool_use_id =
145
-
Incoming.Control_request.Hook_callback.tool_use_id req
146
-
in
147
Log.info (fun m ->
148
m "Hook callback request for callback_id: %s" callback_id);
149
···
156
Jsont.Json.encode Hooks.result_jsont result
157
|> Err.get_ok ~msg:"Failed to encode hook result: "
158
in
159
let response =
160
Control_response.success ~request_id ~response:(Some result_json)
161
in
···
176
Log.err (fun m -> m "%s" error_msg);
177
Transport.send t.transport
178
(Control_response.error ~request_id ~message:error_msg))
179
-
| Incoming.Control_request.Unknown (subtype, _) ->
180
-
let error_msg =
181
-
Printf.sprintf "Unsupported control request: %s" subtype
182
-
in
183
Transport.send t.transport
184
(Control_response.error ~request_id ~message:error_msg)
185
···
229
loop ()
230
| Ok (Incoming.Control_request ctrl_req) ->
231
Log.info (fun m ->
232
-
m "Received control request: %s (request_id: %s)"
233
-
(Incoming.Control_request.subtype ctrl_req)
234
-
(Incoming.Control_request.request_id ctrl_req));
235
handle_control_request t ctrl_req;
236
loop ()
237
| Error err ->
···
91
92
let session_id t = t.session_id
93
94
+
let handle_control_request t (ctrl_req : Sdk_control.control_request) =
95
+
let request_id = ctrl_req.request_id in
96
+
Log.info (fun m -> m "Handling control request: %s" request_id);
97
98
+
match ctrl_req.request with
99
+
| Sdk_control.Request.Permission req ->
100
+
let tool_name = req.tool_name in
101
+
let input = req.input in
102
Log.info (fun m ->
103
m "Permission request for tool '%s' with input: %s" tool_name
104
(json_to_string input));
105
+
(* Convert permission_suggestions to Context *)
106
+
let suggestions = Option.value req.permission_suggestions ~default:[] in
107
+
let context = Permissions.Context.create ~suggestions () in
108
109
Log.info (fun m ->
110
m "Invoking permission callback for tool: %s" tool_name);
···
135
Log.info (fun m ->
136
m "Sending control response: %s" (json_to_string response));
137
Transport.send t.transport response
138
+
| Sdk_control.Request.Hook_callback req -> (
139
+
let callback_id = req.callback_id in
140
+
let input = req.input in
141
+
let tool_use_id = req.tool_use_id in
142
Log.info (fun m ->
143
m "Hook callback request for callback_id: %s" callback_id);
144
···
151
Jsont.Json.encode Hooks.result_jsont result
152
|> Err.get_ok ~msg:"Failed to encode hook result: "
153
in
154
+
Log.debug (fun m ->
155
+
m "Hook result JSON: %s" (json_to_string result_json));
156
let response =
157
Control_response.success ~request_id ~response:(Some result_json)
158
in
···
173
Log.err (fun m -> m "%s" error_msg);
174
Transport.send t.transport
175
(Control_response.error ~request_id ~message:error_msg))
176
+
| _ ->
177
+
(* Other request types not handled here *)
178
+
let error_msg = "Unsupported control request type" in
179
Transport.send t.transport
180
(Control_response.error ~request_id ~message:error_msg)
181
···
225
loop ()
226
| Ok (Incoming.Control_request ctrl_req) ->
227
Log.info (fun m ->
228
+
m "Received control request (request_id: %s)"
229
+
ctrl_req.request_id);
230
handle_control_request t ctrl_req;
231
loop ()
232
| Error err ->
+74
-14
lib/hooks.ml
+74
-14
lib/hooks.ml
···
65
let decision_jsont : decision Jsont.t =
66
Jsont.enum [ ("continue", Continue); ("block", Block) ]
67
68
type result = {
69
decision : decision option;
70
system_message : string option;
···
154
|> Jsont.Object.finish
155
156
let output_to_json output =
157
-
match Jsont.Json.encode output_jsont output with
158
-
| Ok json -> json
159
-
| Error msg -> failwith ("PreToolUse.output_to_json: " ^ msg)
160
161
let allow ?reason ?updated_input ?(unknown = Unknown.empty) () =
162
{
···
257
|> Jsont.Object.finish
258
259
let output_to_json output =
260
-
match Jsont.Json.encode output_jsont output with
261
-
| Ok json -> json
262
-
| Error msg -> failwith ("PostToolUse.output_to_json: " ^ msg)
263
264
let continue ?additional_context ?(unknown = Unknown.empty) () =
265
{ decision = None; reason = None; additional_context; unknown }
···
320
|> Jsont.Object.finish
321
322
let output_to_json output =
323
-
match Jsont.Json.encode output_jsont output with
324
-
| Ok json -> json
325
-
| Error msg -> failwith ("UserPromptSubmit.output_to_json: " ^ msg)
326
327
let continue ?additional_context ?(unknown = Unknown.empty) () =
328
{ decision = None; reason = None; additional_context; unknown }
···
378
|> Jsont.Object.finish
379
380
let output_to_json output =
381
-
match Jsont.Json.encode output_jsont output with
382
-
| Ok json -> json
383
-
| Error msg -> failwith ("Stop.output_to_json: " ^ msg)
384
385
let continue ?(unknown = Unknown.empty) () =
386
{ decision = None; reason = None; unknown }
···
391
392
(** {1 SubagentStop Hook} - Same structure as Stop *)
393
module SubagentStop = struct
394
-
include Stop
395
end
396
397
(** {1 PreCompact Hook} *)
···
425
426
type output = unit (* No specific output for PreCompact *)
427
428
-
let output_to_json () = Jsont.Object ([], Jsont.Meta.none)
429
let continue () = ()
430
end
431
···
65
let decision_jsont : decision Jsont.t =
66
Jsont.enum [ ("continue", Continue); ("block", Block) ]
67
68
+
(** Wire format for hook-specific output that includes hookEventName *)
69
+
module Hook_specific_output = struct
70
+
type t = { hook_event_name : event; output : Jsont.json }
71
+
72
+
let create ~event ~output = { hook_event_name = event; output }
73
+
74
+
let to_json t =
75
+
(* Encode the event name *)
76
+
let event_name_json =
77
+
Jsont.Json.encode event_jsont t.hook_event_name
78
+
|> Err.get_ok ~msg:"Hook_specific_output.to_json: event_name encoding"
79
+
in
80
+
(* Merge hookEventName into the output object *)
81
+
match t.output with
82
+
| Jsont.Object (members, meta) ->
83
+
let hook_event_name_member =
84
+
(Jsont.Json.name "hookEventName", event_name_json)
85
+
in
86
+
Jsont.Object (hook_event_name_member :: members, meta)
87
+
| _ ->
88
+
(* If output is not an object, wrap it *)
89
+
Jsont.Object
90
+
( [
91
+
( Jsont.Json.name "hookEventName",
92
+
event_name_json );
93
+
],
94
+
Jsont.Meta.none )
95
+
end
96
+
97
type result = {
98
decision : decision option;
99
system_message : string option;
···
183
|> Jsont.Object.finish
184
185
let output_to_json output =
186
+
let inner =
187
+
Jsont.Json.encode output_jsont output
188
+
|> Err.get_ok ~msg:"PreToolUse.output_to_json: "
189
+
in
190
+
Hook_specific_output.(create ~event:Pre_tool_use ~output:inner |> to_json)
191
192
let allow ?reason ?updated_input ?(unknown = Unknown.empty) () =
193
{
···
288
|> Jsont.Object.finish
289
290
let output_to_json output =
291
+
let inner =
292
+
Jsont.Json.encode output_jsont output
293
+
|> Err.get_ok ~msg:"PostToolUse.output_to_json: "
294
+
in
295
+
Hook_specific_output.(create ~event:Post_tool_use ~output:inner |> to_json)
296
297
let continue ?additional_context ?(unknown = Unknown.empty) () =
298
{ decision = None; reason = None; additional_context; unknown }
···
353
|> Jsont.Object.finish
354
355
let output_to_json output =
356
+
let inner =
357
+
Jsont.Json.encode output_jsont output
358
+
|> Err.get_ok ~msg:"UserPromptSubmit.output_to_json: "
359
+
in
360
+
Hook_specific_output.(
361
+
create ~event:User_prompt_submit ~output:inner |> to_json)
362
363
let continue ?additional_context ?(unknown = Unknown.empty) () =
364
{ decision = None; reason = None; additional_context; unknown }
···
414
|> Jsont.Object.finish
415
416
let output_to_json output =
417
+
let inner =
418
+
Jsont.Json.encode output_jsont output
419
+
|> Err.get_ok ~msg:"Stop.output_to_json: "
420
+
in
421
+
Hook_specific_output.(create ~event:Stop ~output:inner |> to_json)
422
423
let continue ?(unknown = Unknown.empty) () =
424
{ decision = None; reason = None; unknown }
···
429
430
(** {1 SubagentStop Hook} - Same structure as Stop *)
431
module SubagentStop = struct
432
+
type input = Stop.input
433
+
type t = input
434
+
type output = Stop.output
435
+
436
+
let session_id = Stop.session_id
437
+
let transcript_path = Stop.transcript_path
438
+
let stop_hook_active = Stop.stop_hook_active
439
+
let unknown = Stop.unknown
440
+
let input_jsont = Stop.input_jsont
441
+
let of_json = Stop.of_json
442
+
let output_jsont = Stop.output_jsont
443
+
let continue = Stop.continue
444
+
let block = Stop.block
445
+
446
+
let output_to_json output =
447
+
let inner =
448
+
Jsont.Json.encode output_jsont output
449
+
|> Err.get_ok ~msg:"SubagentStop.output_to_json: "
450
+
in
451
+
Hook_specific_output.(create ~event:Subagent_stop ~output:inner |> to_json)
452
end
453
454
(** {1 PreCompact Hook} *)
···
482
483
type output = unit (* No specific output for PreCompact *)
484
485
+
let output_to_json () =
486
+
let inner = Jsont.Object ([], Jsont.Meta.none) in
487
+
Hook_specific_output.(create ~event:Pre_compact ~output:inner |> to_json)
488
+
489
let continue () = ()
490
end
491
+12
-1
lib/hooks.mli
+12
-1
lib/hooks.mli
···
268
269
(** SubagentStop hook - fires when a subagent stops *)
270
module SubagentStop : sig
271
+
type input = Stop.input
272
+
type t = input
273
+
type output = Stop.output
274
275
val of_json : Jsont.json -> t
276
+
val session_id : t -> string
277
+
val transcript_path : t -> string
278
+
val stop_hook_active : t -> bool
279
+
val unknown : t -> Unknown.t
280
+
val input_jsont : input Jsont.t
281
+
val output_jsont : output Jsont.t
282
+
val continue : ?unknown:Unknown.t -> unit -> output
283
+
val block : ?reason:string -> ?unknown:Unknown.t -> unit -> output
284
+
val output_to_json : output -> Jsont.json
285
end
286
287
(** PreCompact hook - fires before message compaction *)
+55
-183
lib/incoming.ml
+55
-183
lib/incoming.ml
···
3
4
module Log = (val Logs.src_log src : Logs.LOG)
5
6
-
(** Control request types for incoming control_request messages *)
7
-
module Control_request = struct
8
-
(** Can use tool permission request *)
9
-
module Can_use_tool = struct
10
-
type t = {
11
-
tool_name : string;
12
-
input : Jsont.json;
13
-
permission_suggestions : Jsont.json list;
14
-
}
15
-
16
-
let tool_name t = t.tool_name
17
-
let input t = t.input
18
-
let permission_suggestions t = t.permission_suggestions
19
-
20
-
let jsont : t Jsont.t =
21
-
let make tool_name input permission_suggestions =
22
-
{
23
-
tool_name;
24
-
input;
25
-
permission_suggestions =
26
-
Option.value permission_suggestions ~default:[];
27
-
}
28
-
in
29
-
Jsont.Object.map ~kind:"CanUseTool" make
30
-
|> Jsont.Object.mem "tool_name" Jsont.string ~enc:tool_name
31
-
|> Jsont.Object.mem "input" Jsont.json ~enc:input
32
-
|> Jsont.Object.opt_mem "permission_suggestions" (Jsont.list Jsont.json)
33
-
~enc:(fun t ->
34
-
if t.permission_suggestions = [] then None
35
-
else Some t.permission_suggestions)
36
-
|> Jsont.Object.finish
37
-
end
38
-
39
-
(** Hook callback request *)
40
-
module Hook_callback = struct
41
-
type t = {
42
-
callback_id : string;
43
-
input : Jsont.json;
44
-
tool_use_id : string option;
45
-
}
46
-
47
-
let callback_id t = t.callback_id
48
-
let input t = t.input
49
-
let tool_use_id t = t.tool_use_id
50
-
51
-
let jsont : t Jsont.t =
52
-
let make callback_id input tool_use_id =
53
-
{ callback_id; input; tool_use_id }
54
-
in
55
-
Jsont.Object.map ~kind:"HookCallback" make
56
-
|> Jsont.Object.mem "callback_id" Jsont.string ~enc:callback_id
57
-
|> Jsont.Object.mem "input" Jsont.json ~enc:input
58
-
|> Jsont.Object.opt_mem "tool_use_id" Jsont.string ~enc:tool_use_id
59
-
|> Jsont.Object.finish
60
-
end
61
62
-
(** Request payload - discriminated by subtype *)
63
-
type request =
64
-
| Can_use_tool of Can_use_tool.t
65
-
| Hook_callback of Hook_callback.t
66
-
| Unknown of string * Jsont.json
67
-
68
-
let request_of_json json =
69
-
let subtype_codec =
70
-
Jsont.Object.map ~kind:"Subtype" Fun.id
71
-
|> Jsont.Object.mem "subtype" Jsont.string ~enc:Fun.id
72
-
|> Jsont.Object.finish
73
-
in
74
-
match Jsont.Json.decode subtype_codec json with
75
-
| Error _ -> Unknown ("unknown", json)
76
-
| Ok subtype -> (
77
-
match subtype with
78
-
| "can_use_tool" -> (
79
-
match Jsont.Json.decode Can_use_tool.jsont json with
80
-
| Ok r -> Can_use_tool r
81
-
| Error _ -> Unknown (subtype, json))
82
-
| "hook_callback" -> (
83
-
match Jsont.Json.decode Hook_callback.jsont json with
84
-
| Ok r -> Hook_callback r
85
-
| Error _ -> Unknown (subtype, json))
86
-
| _ -> Unknown (subtype, json))
87
-
88
-
type t = { request_id : string; request : request }
89
-
(** Full control request message *)
90
-
91
-
let request_id t = t.request_id
92
-
let request t = t.request
93
-
94
-
let subtype t =
95
-
match t.request with
96
-
| Can_use_tool _ -> "can_use_tool"
97
-
| Hook_callback _ -> "hook_callback"
98
-
| Unknown (s, _) -> s
99
-
100
-
let jsont : t Jsont.t =
101
-
let dec json =
102
-
let envelope_codec =
103
-
Jsont.Object.map ~kind:"ControlRequestEnvelope"
104
-
(fun request_id request_json -> (request_id, request_json))
105
-
|> Jsont.Object.mem "request_id" Jsont.string ~enc:fst
106
-
|> Jsont.Object.mem "request" Jsont.json ~enc:snd
107
-
|> Jsont.Object.finish
108
-
in
109
-
match Jsont.Json.decode envelope_codec json with
110
-
| Error err ->
111
-
failwith ("Failed to decode control_request envelope: " ^ err)
112
-
| Ok (request_id, request_json) ->
113
-
{ request_id; request = request_of_json request_json }
114
-
in
115
-
let enc t =
116
-
let request_json =
117
-
match t.request with
118
-
| Can_use_tool r -> (
119
-
match Jsont.Json.encode Can_use_tool.jsont r with
120
-
| Ok j -> j
121
-
| Error err -> failwith ("Failed to encode Can_use_tool: " ^ err))
122
-
| Hook_callback r -> (
123
-
match Jsont.Json.encode Hook_callback.jsont r with
124
-
| Ok j -> j
125
-
| Error err -> failwith ("Failed to encode Hook_callback: " ^ err))
126
-
| Unknown (_, j) -> j
127
-
in
128
-
Jsont.Json.object'
129
-
[
130
-
Jsont.Json.mem (Jsont.Json.name "type")
131
-
(Jsont.Json.string "control_request");
132
-
Jsont.Json.mem
133
-
(Jsont.Json.name "request_id")
134
-
(Jsont.Json.string t.request_id);
135
-
Jsont.Json.mem (Jsont.Json.name "request") request_json;
136
-
]
137
-
in
138
-
Jsont.map ~kind:"ControlRequest" ~dec ~enc Jsont.json
139
-
end
140
141
type t =
142
| Message of Message.t
143
| Control_response of Sdk_control.control_response
144
-
| Control_request of Control_request.t
145
146
let jsont : t Jsont.t =
147
-
(* Custom decoder that checks the type field and dispatches to the appropriate codec.
148
149
-
The challenge is that Message can have multiple type values ("user", "assistant",
150
-
"system", "result"), while control_response and control_request have single type values.
151
-
Jsont's case_mem discriminator doesn't support multiple tags per case, so we implement
152
-
a custom decoder/encoder. *)
153
-
let type_field_codec =
154
-
Jsont.Object.map ~kind:"type_field" Fun.id
155
-
|> Jsont.Object.opt_mem "type" Jsont.string ~enc:Fun.id
156
-
|> Jsont.Object.finish
157
in
158
-
159
-
let dec json =
160
-
match Jsont.Json.decode type_field_codec json with
161
-
| Error _ | Ok None -> (
162
-
(* No type field, try as message *)
163
-
match Jsont.Json.decode Message.jsont json with
164
-
| Ok msg -> Message msg
165
-
| Error err -> failwith ("Failed to decode message: " ^ err))
166
-
| Ok (Some typ) -> (
167
-
match typ with
168
-
| "control_response" -> (
169
-
match Jsont.Json.decode Sdk_control.control_response_jsont json with
170
-
| Ok resp -> Control_response resp
171
-
| Error err -> failwith ("Failed to decode control_response: " ^ err)
172
-
)
173
-
| "control_request" -> (
174
-
match Jsont.Json.decode Control_request.jsont json with
175
-
| Ok req -> Control_request req
176
-
| Error err -> failwith ("Failed to decode control_request: " ^ err)
177
-
)
178
-
| "user" | "assistant" | "system" | "result" | _ -> (
179
-
(* Message types *)
180
-
match Jsont.Json.decode Message.jsont json with
181
-
| Ok msg -> Message msg
182
-
| Error err -> failwith ("Failed to decode message: " ^ err)))
183
in
184
-
185
-
let enc = function
186
| Message msg -> (
187
-
match Jsont.Json.encode Message.jsont msg with
188
-
| Ok json -> json
189
-
| Error err -> failwith ("Failed to encode message: " ^ err))
190
-
| Control_response resp -> (
191
-
match Jsont.Json.encode Sdk_control.control_response_jsont resp with
192
-
| Ok json -> json
193
-
| Error err -> failwith ("Failed to encode control response: " ^ err))
194
-
| Control_request req -> (
195
-
match Jsont.Json.encode Control_request.jsont req with
196
-
| Ok json -> json
197
-
| Error err -> failwith ("Failed to encode control request: " ^ err))
198
in
199
-
200
-
Jsont.map ~kind:"Incoming" ~dec ~enc Jsont.json
···
3
4
module Log = (val Logs.src_log src : Logs.LOG)
5
6
+
(** Incoming messages from Claude CLI.
7
8
+
This uses the Sdk_control module's control_request_jsont and
9
+
control_response_jsont for control messages, and Message.jsont for
10
+
conversation messages. The top-level discriminator is the "type" field. *)
11
12
type t =
13
| Message of Message.t
14
| Control_response of Sdk_control.control_response
15
+
| Control_request of Sdk_control.control_request
16
17
let jsont : t Jsont.t =
18
+
(* Message types use "user", "assistant", "system", "result" as type values.
19
+
Control uses "control_request" and "control_response".
20
21
+
We use case_mem for all types. Note: we use the inner message codecs
22
+
(User.incoming_jsont, etc.) rather than Message.jsont to avoid nesting
23
+
case_mem on the same "type" field. *)
24
+
let case_control_request =
25
+
Jsont.Object.Case.map "control_request" Sdk_control.control_request_jsont
26
+
~dec:(fun v -> Control_request v)
27
+
in
28
+
let case_control_response =
29
+
Jsont.Object.Case.map "control_response" Sdk_control.control_response_jsont
30
+
~dec:(fun v -> Control_response v)
31
in
32
+
let case_user =
33
+
Jsont.Object.Case.map "user" Message.User.incoming_jsont
34
+
~dec:(fun v -> Message (Message.User v))
35
+
in
36
+
let case_assistant =
37
+
Jsont.Object.Case.map "assistant" Message.Assistant.incoming_jsont
38
+
~dec:(fun v -> Message (Message.Assistant v))
39
+
in
40
+
let case_system =
41
+
Jsont.Object.Case.map "system" Message.System.jsont
42
+
~dec:(fun v -> Message (Message.System v))
43
+
in
44
+
let case_result =
45
+
Jsont.Object.Case.map "result" Message.Result.jsont
46
+
~dec:(fun v -> Message (Message.Result v))
47
in
48
+
let enc_case = function
49
+
| Control_request v -> Jsont.Object.Case.value case_control_request v
50
+
| Control_response v -> Jsont.Object.Case.value case_control_response v
51
| Message msg -> (
52
+
match msg with
53
+
| Message.User u -> Jsont.Object.Case.value case_user u
54
+
| Message.Assistant a -> Jsont.Object.Case.value case_assistant a
55
+
| Message.System s -> Jsont.Object.Case.value case_system s
56
+
| Message.Result r -> Jsont.Object.Case.value case_result r)
57
+
in
58
+
let cases =
59
+
Jsont.Object.Case.
60
+
[
61
+
make case_control_request;
62
+
make case_control_response;
63
+
make case_user;
64
+
make case_assistant;
65
+
make case_system;
66
+
make case_result;
67
+
]
68
in
69
+
Jsont.Object.map ~kind:"Incoming" Fun.id
70
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
71
+
~tag_to_string:Fun.id ~tag_compare:String.compare
72
+
|> Jsont.Object.finish
+2
-39
lib/incoming.mli
+2
-39
lib/incoming.mli
···
9
- "control_request" -> Control_request variant
10
11
This provides a clean, type-safe way to decode incoming messages in a single
12
-
operation, avoiding the parse-then-switch-then-parse pattern. *)
13
-
14
-
(** Control request types for incoming control_request messages *)
15
-
module Control_request : sig
16
-
(** Can use tool permission request *)
17
-
module Can_use_tool : sig
18
-
type t
19
-
20
-
val tool_name : t -> string
21
-
val input : t -> Jsont.json
22
-
val permission_suggestions : t -> Jsont.json list
23
-
val jsont : t Jsont.t
24
-
end
25
-
26
-
(** Hook callback request *)
27
-
module Hook_callback : sig
28
-
type t
29
-
30
-
val callback_id : t -> string
31
-
val input : t -> Jsont.json
32
-
val tool_use_id : t -> string option
33
-
val jsont : t Jsont.t
34
-
end
35
-
36
-
(** Request payload - discriminated by subtype *)
37
-
type request =
38
-
| Can_use_tool of Can_use_tool.t
39
-
| Hook_callback of Hook_callback.t
40
-
| Unknown of string * Jsont.json
41
-
42
-
type t
43
-
(** Full control request message *)
44
-
45
-
val request_id : t -> string
46
-
val request : t -> request
47
-
val subtype : t -> string
48
-
val jsont : t Jsont.t
49
-
end
50
51
type t =
52
| Message of Message.t
53
| Control_response of Sdk_control.control_response
54
-
| Control_request of Control_request.t
55
56
val jsont : t Jsont.t
57
(** Codec for incoming messages. Uses the "type" field to discriminate. Use
···
9
- "control_request" -> Control_request variant
10
11
This provides a clean, type-safe way to decode incoming messages in a single
12
+
operation. *)
13
14
type t =
15
| Message of Message.t
16
| Control_response of Sdk_control.control_response
17
+
| Control_request of Sdk_control.control_request
18
19
val jsont : t Jsont.t
20
(** Codec for incoming messages. Uses the "type" field to discriminate. Use
+4
-26
lib/message.ml
+4
-26
lib/message.ml
···
286
}
287
288
type error = { error : string; unknown : Unknown.t }
289
-
type other = { subtype : string; unknown : Unknown.t }
290
-
type t = Init of init | Error of error | Other of other
291
292
(* Accessors *)
293
let session_id = function Init i -> i.session_id | _ -> None
294
let model = function Init i -> i.model | _ -> None
295
let cwd = function Init i -> i.cwd | _ -> None
296
let error_msg = function Error e -> Some e.error | _ -> None
297
-
298
-
let subtype = function
299
-
| Init _ -> "init"
300
-
| Error _ -> "error"
301
-
| Other o -> o.subtype
302
-
303
-
let unknown = function
304
-
| Init i -> i.unknown
305
-
| Error e -> e.unknown
306
-
| Other o -> o.unknown
307
308
(* Constructors *)
309
let init ?session_id ?model ?cwd () =
310
Init { session_id; model; cwd; unknown = Unknown.empty }
311
312
let error ~error = Error { error; unknown = Unknown.empty }
313
-
let other ~subtype = Other { subtype; unknown = Unknown.empty }
314
315
(* Individual record codecs *)
316
let init_jsont : init Jsont.t =
···
343
let case_error =
344
Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
345
in
346
-
let case_other tag =
347
-
(* For unknown subtypes, create Other with the tag as subtype *)
348
-
let other_codec : other Jsont.t =
349
-
let make unknown : other = { subtype = tag; unknown } in
350
-
Jsont.Object.map ~kind:"SystemOther" make
351
-
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun (r : other) ->
352
-
r.unknown)
353
-
|> Jsont.Object.finish
354
-
in
355
-
Jsont.Object.Case.map tag other_codec ~dec:(fun v -> Other v)
356
-
in
357
let enc_case = function
358
| Init v -> Jsont.Object.Case.value case_init v
359
| Error v -> Jsont.Object.Case.value case_error v
360
-
| Other v -> Jsont.Object.Case.value (case_other v.subtype) v
361
in
362
let cases = Jsont.Object.Case.[ make case_init; make case_error ] in
363
Jsont.Object.map ~kind:"System" Fun.id
···
665
666
let is_error = function
667
| Result r -> Result.is_error r
668
-
| System s -> System.subtype s = "error"
669
| _ -> false
670
671
let extract_text = function
···
286
}
287
288
type error = { error : string; unknown : Unknown.t }
289
+
type t = Init of init | Error of error
290
291
(* Accessors *)
292
let session_id = function Init i -> i.session_id | _ -> None
293
let model = function Init i -> i.model | _ -> None
294
let cwd = function Init i -> i.cwd | _ -> None
295
let error_msg = function Error e -> Some e.error | _ -> None
296
+
let subtype = function Init _ -> "init" | Error _ -> "error"
297
+
let unknown = function Init i -> i.unknown | Error e -> e.unknown
298
299
(* Constructors *)
300
let init ?session_id ?model ?cwd () =
301
Init { session_id; model; cwd; unknown = Unknown.empty }
302
303
let error ~error = Error { error; unknown = Unknown.empty }
304
305
(* Individual record codecs *)
306
let init_jsont : init Jsont.t =
···
333
let case_error =
334
Jsont.Object.Case.map "error" error_jsont ~dec:(fun v -> Error v)
335
in
336
let enc_case = function
337
| Init v -> Jsont.Object.Case.value case_init v
338
| Error v -> Jsont.Object.Case.value case_error v
339
in
340
let cases = Jsont.Object.Case.[ make case_init; make case_error ] in
341
Jsont.Object.map ~kind:"System" Fun.id
···
643
644
let is_error = function
645
| Result r -> Result.is_error r
646
+
| System (System.Error _) -> true
647
| _ -> false
648
649
let extract_text = function
+10
-12
lib/message.mli
+10
-12
lib/message.mli
···
24
val jsont : t Jsont.t
25
(** [jsont] is the Jsont codec for user messages. *)
26
27
val create_string : string -> t
28
(** [create_string s] creates a user message with simple text content. *)
29
···
90
val jsont : t Jsont.t
91
(** [jsont] is the Jsont codec for assistant messages. *)
92
93
val create :
94
content:Content_block.t list -> model:string -> ?error:error -> unit -> t
95
(** [create ~content ~model ?error ()] creates an assistant message.
···
141
142
System messages use a discriminated union on the "subtype" field:
143
- "init": Session initialization with session_id, model, cwd
144
-
- "error": Error messages with error string
145
-
- Other subtypes are preserved as [Other] *)
146
147
type init = {
148
session_id : string option;
···
155
type error = { error : string; unknown : Unknown.t }
156
(** Error message fields. *)
157
158
-
type other = { subtype : string; unknown : Unknown.t }
159
-
(** Unknown subtype fields. *)
160
-
161
-
type t =
162
-
| Init of init
163
-
| Error of error
164
-
| Other of other (** The type of system messages. *)
165
166
val jsont : t Jsont.t
167
(** [jsont] is the Jsont codec for system messages. *)
···
173
174
val error : error:string -> t
175
(** [error ~error] creates an error message. *)
176
-
177
-
val other : subtype:string -> t
178
-
(** [other ~subtype] creates a message with unknown subtype. *)
179
180
(** {2 Accessors} *)
181
···
24
val jsont : t Jsont.t
25
(** [jsont] is the Jsont codec for user messages. *)
26
27
+
val incoming_jsont : t Jsont.t
28
+
(** [incoming_jsont] is the codec for parsing incoming user messages from CLI.
29
+
This parses the envelope format with "message" wrapper. *)
30
+
31
val create_string : string -> t
32
(** [create_string s] creates a user message with simple text content. *)
33
···
94
val jsont : t Jsont.t
95
(** [jsont] is the Jsont codec for assistant messages. *)
96
97
+
val incoming_jsont : t Jsont.t
98
+
(** [incoming_jsont] is the codec for parsing incoming assistant messages from
99
+
CLI. This parses the envelope format with "message" wrapper. *)
100
+
101
val create :
102
content:Content_block.t list -> model:string -> ?error:error -> unit -> t
103
(** [create ~content ~model ?error ()] creates an assistant message.
···
149
150
System messages use a discriminated union on the "subtype" field:
151
- "init": Session initialization with session_id, model, cwd
152
+
- "error": Error messages with error string *)
153
154
type init = {
155
session_id : string option;
···
162
type error = { error : string; unknown : Unknown.t }
163
(** Error message fields. *)
164
165
+
type t = Init of init | Error of error
166
167
val jsont : t Jsont.t
168
(** [jsont] is the Jsont codec for system messages. *)
···
174
175
val error : error:string -> t
176
(** [error ~error] creates an error message. *)
177
178
(** {2 Accessors} *)
179
+3
lib/sdk_control.mli
+3
lib/sdk_control.mli
···
228
}
229
(** Control response message. *)
230
231
+
val control_request_jsont : control_request Jsont.t
232
+
(** [control_request_jsont] is the jsont codec for control request messages. *)
233
+
234
val control_response_jsont : control_response Jsont.t
235
(** [control_response_jsont] is the jsont codec for control response messages.
236
*)
+3
-4
test/structured_output_demo.ml
+3
-4
test/structured_output_demo.ml
···
199
match C.Message.Result.result result with
200
| Some text -> Printf.printf "Text result: %s\n" text
201
| None -> ()))
202
-
| C.Message.System sys -> (
203
-
match C.Message.System.subtype sys with
204
-
| "init" -> Printf.printf "Session initialized\n"
205
-
| _ -> ())
206
| _ -> ())
207
messages;
208
···
199
match C.Message.Result.result result with
200
| Some text -> Printf.printf "Text result: %s\n" text
201
| None -> ()))
202
+
| C.Message.System (C.Message.System.Init _) ->
203
+
Printf.printf "Session initialized\n"
204
+
| C.Message.System (C.Message.System.Error _) -> ()
205
| _ -> ())
206
messages;
207