My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1let src = Logs.Src.create "claude.incoming" ~doc:"Incoming messages from Claude CLI"
2module Log = (val Logs.src_log src : Logs.LOG)
3
4(** Control request types for incoming control_request messages *)
5module 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
123end
124
125type t =
126 | Message of Message.t
127 | Control_response of Sdk_control.control_response
128 | Control_request of Control_request.t
129
130let jsont : t Jsont.t =
131 (* Custom decoder that checks the type field and dispatches to the appropriate codec.
132
133 The challenge is that Message can have multiple type values ("user", "assistant",
134 "system", "result"), while control_response and control_request have single type values.
135 Jsont's case_mem discriminator doesn't support multiple tags per case, so we implement
136 a custom decoder/encoder. *)
137
138 let type_field_codec = Jsont.Object.map ~kind:"type_field" Fun.id
139 |> Jsont.Object.opt_mem "type" Jsont.string ~enc:Fun.id
140 |> Jsont.Object.finish
141 in
142
143 let dec json =
144 match Jsont.Json.decode type_field_codec json with
145 | Error _ | Ok None ->
146 (* No type field, try as message *)
147 (match Jsont.Json.decode Message.jsont json with
148 | Ok msg -> Message msg
149 | Error err -> failwith ("Failed to decode message: " ^ err))
150 | Ok (Some typ) ->
151 match typ with
152 | "control_response" ->
153 (match Jsont.Json.decode Sdk_control.control_response_jsont json with
154 | Ok resp -> Control_response resp
155 | Error err -> failwith ("Failed to decode control_response: " ^ err))
156 | "control_request" ->
157 (match Jsont.Json.decode Control_request.jsont json with
158 | Ok req -> Control_request req
159 | Error err -> failwith ("Failed to decode control_request: " ^ err))
160 | "user" | "assistant" | "system" | "result" | _ ->
161 (* Message types *)
162 (match Jsont.Json.decode Message.jsont json with
163 | Ok msg -> Message msg
164 | Error err -> failwith ("Failed to decode message: " ^ err))
165 in
166
167 let enc = function
168 | Message msg ->
169 (match Jsont.Json.encode Message.jsont msg with
170 | Ok json -> json
171 | Error err -> failwith ("Failed to encode message: " ^ err))
172 | Control_response resp ->
173 (match Jsont.Json.encode Sdk_control.control_response_jsont resp with
174 | Ok json -> json
175 | Error err -> failwith ("Failed to encode control response: " ^ err))
176 | Control_request req ->
177 (match Jsont.Json.encode Control_request.jsont req with
178 | Ok json -> json
179 | Error err -> failwith ("Failed to encode control request: " ^ err))
180 in
181
182 Jsont.map ~kind:"Incoming" ~dec ~enc Jsont.json
183
184let pp fmt = function
185 | Message msg -> Format.fprintf fmt "@[<2>Message@ %a@]" Message.pp msg
186 | Control_response resp -> Format.fprintf fmt "@[<2>ControlResponse@ %a@]" Sdk_control.pp (Sdk_control.Response resp)
187 | Control_request req -> Format.fprintf fmt "@[<2>ControlRequest@ { request_id=%S; subtype=%S }@]"
188 (Control_request.request_id req) (Control_request.subtype req)