anil.recoil.org
Matrix protocol in OCaml, Eio specialised
1(** Event relations: reactions, edits, threads, and replies. *)
2
3(* Relation types *)
4type relation_type =
5 | Annotation (* m.annotation - reactions *)
6 | Reference (* m.reference - generic reference *)
7 | Replace (* m.replace - edits *)
8 | Thread (* m.thread - threads *)
9
10let relation_type_to_string = function
11 | Annotation -> "m.annotation"
12 | Reference -> "m.reference"
13 | Replace -> "m.replace"
14 | Thread -> "m.thread"
15
16let relation_type_of_string = function
17 | "m.annotation" -> Ok Annotation
18 | "m.reference" -> Ok Reference
19 | "m.replace" -> Ok Replace
20 | "m.thread" -> Ok Thread
21 | s -> Error ("Unknown relation type: " ^ s)
22
23let relation_type_jsont =
24 Jsont.of_of_string ~kind:"relation_type"
25 ~enc:relation_type_to_string
26 relation_type_of_string
27[@@warning "-32"]
28
29(* Reaction *)
30type reaction = {
31 event_id : Matrix_proto.Id.Event_id.t;
32 key : string; (* emoji or shortcode *)
33}
34
35(* Send a reaction to an event *)
36type reaction_content = {
37 relates_to : reaction_relates_to;
38} [@@warning "-69"]
39
40and reaction_relates_to = {
41 rel_type : string;
42 event_id : string;
43 key : string;
44} [@@warning "-69"]
45
46let reaction_relates_to_jsont =
47 Jsont.Object.(
48 map (fun rel_type event_id key -> { rel_type; event_id; key })
49 |> mem "rel_type" Jsont.string
50 |> mem "event_id" Jsont.string
51 |> mem "key" Jsont.string
52 |> finish)
53
54let reaction_content_jsont =
55 Jsont.Object.(
56 map (fun relates_to -> { relates_to })
57 |> mem "m.relates_to" reaction_relates_to_jsont
58 |> finish)
59
60let send_reaction client ~room_id ~event_id ~key =
61 let room_id_str = Matrix_proto.Id.Room_id.to_string room_id in
62 let event_id_str = Matrix_proto.Id.Event_id.to_string event_id in
63 let path = Printf.sprintf "/rooms/%s/send/m.reaction" (Uri.pct_encode room_id_str) in
64 let content = {
65 relates_to = {
66 rel_type = "m.annotation";
67 event_id = event_id_str;
68 key;
69 }
70 } in
71 match Client.encode_body reaction_content_jsont content with
72 | Error e -> Error e
73 | Ok body ->
74 match Client.post client ~path ~body () with
75 | Error e -> Error e
76 | Ok body ->
77 match Client.decode_response Messages.send_response_jsont body with
78 | Error e -> Error e
79 | Ok resp -> Ok resp.event_id
80
81(* Edit a message *)
82type edit_content = {
83 msgtype : string;
84 body : string;
85 new_content : edit_new_content;
86 relates_to : edit_relates_to;
87} [@@warning "-69"]
88
89and edit_new_content = {
90 msgtype : string;
91 body : string;
92} [@@warning "-69"]
93
94and edit_relates_to = {
95 rel_type : string;
96 event_id : string;
97} [@@warning "-69"]
98
99let edit_new_content_jsont =
100 Jsont.Object.(
101 map (fun msgtype body -> { msgtype; body })
102 |> mem "msgtype" Jsont.string
103 |> mem "body" Jsont.string
104 |> finish)
105
106let edit_relates_to_jsont =
107 Jsont.Object.(
108 map (fun rel_type event_id -> { rel_type; event_id })
109 |> mem "rel_type" Jsont.string
110 |> mem "event_id" Jsont.string
111 |> finish)
112
113let edit_content_jsont =
114 Jsont.Object.(
115 map (fun msgtype body new_content relates_to ->
116 { msgtype; body; new_content; relates_to })
117 |> mem "msgtype" Jsont.string
118 |> mem "body" Jsont.string
119 |> mem "m.new_content" edit_new_content_jsont
120 |> mem "m.relates_to" edit_relates_to_jsont
121 |> finish)
122
123let edit_message client ~room_id ~event_id ~new_body =
124 let room_id_str = Matrix_proto.Id.Room_id.to_string room_id in
125 let event_id_str = Matrix_proto.Id.Event_id.to_string event_id in
126 let path = Printf.sprintf "/rooms/%s/send/m.room.message" (Uri.pct_encode room_id_str) in
127 let content = {
128 msgtype = "m.text";
129 body = "* " ^ new_body; (* Fallback for clients that don't support edits *)
130 new_content = {
131 msgtype = "m.text";
132 body = new_body;
133 };
134 relates_to = {
135 rel_type = "m.replace";
136 event_id = event_id_str;
137 };
138 } in
139 match Client.encode_body edit_content_jsont content with
140 | Error e -> Error e
141 | Ok body ->
142 match Client.post client ~path ~body () with
143 | Error e -> Error e
144 | Ok body ->
145 match Client.decode_response Messages.send_response_jsont body with
146 | Error e -> Error e
147 | Ok resp -> Ok resp.event_id
148
149(* Reply to a message *)
150type reply_relates_to = {
151 in_reply_to : reply_in_reply_to;
152} [@@warning "-69"]
153
154and reply_in_reply_to = {
155 event_id : string;
156} [@@warning "-69"]
157
158type reply_content = {
159 msgtype : string;
160 body : string;
161 relates_to : reply_relates_to;
162} [@@warning "-69"]
163
164let reply_in_reply_to_jsont =
165 Jsont.Object.(
166 map (fun event_id -> { event_id })
167 |> mem "event_id" Jsont.string
168 |> finish)
169
170let reply_relates_to_jsont =
171 Jsont.Object.(
172 map (fun in_reply_to -> { in_reply_to })
173 |> mem "m.in_reply_to" reply_in_reply_to_jsont
174 |> finish)
175
176let reply_content_jsont =
177 Jsont.Object.(
178 map (fun msgtype body relates_to -> { msgtype; body; relates_to })
179 |> mem "msgtype" Jsont.string
180 |> mem "body" Jsont.string
181 |> mem "m.relates_to" reply_relates_to_jsont
182 |> finish)
183
184let send_reply client ~room_id ~event_id ~body =
185 let room_id_str = Matrix_proto.Id.Room_id.to_string room_id in
186 let event_id_str = Matrix_proto.Id.Event_id.to_string event_id in
187 let path = Printf.sprintf "/rooms/%s/send/m.room.message" (Uri.pct_encode room_id_str) in
188 let content = {
189 msgtype = "m.text";
190 body;
191 relates_to = {
192 in_reply_to = {
193 event_id = event_id_str;
194 };
195 };
196 } in
197 match Client.encode_body reply_content_jsont content with
198 | Error e -> Error e
199 | Ok body ->
200 match Client.post client ~path ~body () with
201 | Error e -> Error e
202 | Ok resp_body ->
203 match Client.decode_response Messages.send_response_jsont resp_body with
204 | Error e -> Error e
205 | Ok resp -> Ok resp.event_id
206
207(* Thread message *)
208type thread_relates_to = {
209 rel_type : string;
210 event_id : string;
211 is_falling_back : bool;
212 in_reply_to : reply_in_reply_to option;
213} [@@warning "-69"]
214
215type thread_content = {
216 msgtype : string;
217 body : string;
218 relates_to : thread_relates_to;
219} [@@warning "-69"]
220
221let thread_relates_to_jsont =
222 Jsont.Object.(
223 map (fun rel_type event_id is_falling_back in_reply_to ->
224 { rel_type; event_id; is_falling_back; in_reply_to })
225 |> mem "rel_type" Jsont.string
226 |> mem "event_id" Jsont.string
227 |> mem "is_falling_back" Jsont.bool ~dec_absent:true
228 |> opt_mem "m.in_reply_to" reply_in_reply_to_jsont ~enc:(fun t -> t.in_reply_to)
229 |> finish)
230
231let thread_content_jsont =
232 Jsont.Object.(
233 map (fun msgtype body relates_to -> { msgtype; body; relates_to })
234 |> mem "msgtype" Jsont.string
235 |> mem "body" Jsont.string
236 |> mem "m.relates_to" thread_relates_to_jsont
237 |> finish)
238
239let send_in_thread client ~room_id ~thread_root_id ?reply_to_id ~body () =
240 let room_id_str = Matrix_proto.Id.Room_id.to_string room_id in
241 let thread_root_str = Matrix_proto.Id.Event_id.to_string thread_root_id in
242 let path = Printf.sprintf "/rooms/%s/send/m.room.message" (Uri.pct_encode room_id_str) in
243 let in_reply_to = match reply_to_id with
244 | Some id -> Some { event_id = Matrix_proto.Id.Event_id.to_string id }
245 | None -> None
246 in
247 let content = {
248 msgtype = "m.text";
249 body;
250 relates_to = {
251 rel_type = "m.thread";
252 event_id = thread_root_str;
253 is_falling_back = Option.is_none reply_to_id;
254 in_reply_to;
255 };
256 } in
257 match Client.encode_body thread_content_jsont content with
258 | Error e -> Error e
259 | Ok body ->
260 match Client.post client ~path ~body () with
261 | Error e -> Error e
262 | Ok resp_body ->
263 match Client.decode_response Messages.send_response_jsont resp_body with
264 | Error e -> Error e
265 | Ok resp -> Ok resp.event_id
266
267(* Get relations for an event *)
268type aggregation = {
269 event_id : Matrix_proto.Id.Event_id.t;
270 origin_server_ts : int64;
271 sender : Matrix_proto.Id.User_id.t;
272}
273
274let aggregation_jsont =
275 Jsont.Object.(
276 map (fun event_id origin_server_ts sender ->
277 { event_id; origin_server_ts; sender })
278 |> mem "event_id" Matrix_proto.Id.Event_id.jsont
279 |> mem "origin_server_ts" Jsont.int64
280 |> mem "sender" Matrix_proto.Id.User_id.jsont
281 |> finish)
282
283type relations_response = {
284 chunk : aggregation list;
285 next_batch : string option;
286 prev_batch : string option;
287}
288
289let relations_response_jsont =
290 Jsont.Object.(
291 map (fun chunk next_batch prev_batch ->
292 { chunk; next_batch; prev_batch })
293 |> mem "chunk" (Jsont.list aggregation_jsont) ~dec_absent:[]
294 |> opt_mem "next_batch" Jsont.string ~enc:(fun t -> t.next_batch)
295 |> opt_mem "prev_batch" Jsont.string ~enc:(fun t -> t.prev_batch)
296 |> finish)
297
298let get_relations client ~room_id ~event_id ?rel_type ?event_type ?limit ?from () =
299 let room_id_str = Matrix_proto.Id.Room_id.to_string room_id in
300 let event_id_str = Matrix_proto.Id.Event_id.to_string event_id in
301 let path = match rel_type, event_type with
302 | Some rt, Some et ->
303 Printf.sprintf "/rooms/%s/relations/%s/%s/%s"
304 (Uri.pct_encode room_id_str)
305 (Uri.pct_encode event_id_str)
306 (Uri.pct_encode (relation_type_to_string rt))
307 (Uri.pct_encode et)
308 | Some rt, None ->
309 Printf.sprintf "/rooms/%s/relations/%s/%s"
310 (Uri.pct_encode room_id_str)
311 (Uri.pct_encode event_id_str)
312 (Uri.pct_encode (relation_type_to_string rt))
313 | None, _ ->
314 Printf.sprintf "/rooms/%s/relations/%s"
315 (Uri.pct_encode room_id_str)
316 (Uri.pct_encode event_id_str)
317 in
318 let query =
319 []
320 |> (fun q -> match limit with Some l -> ("limit", string_of_int l) :: q | None -> q)
321 |> (fun q -> match from with Some f -> ("from", f) :: q | None -> q)
322 in
323 let query = if query = [] then None else Some query in
324 match Client.get client ~path ?query () with
325 | Error e -> Error e
326 | Ok body -> Client.decode_response relations_response_jsont body
327
328(* Get all reactions for an event *)
329let get_reactions client ~room_id ~event_id =
330 get_relations client ~room_id ~event_id ~rel_type:Annotation ~event_type:"m.reaction" ()