anil.recoil.org
Matrix protocol in OCaml, Eio specialised
1(** Sync operations and long-polling loop. *)
2
3(* Sync parameters *)
4type params = {
5 filter : string option;
6 since : string option;
7 full_state : bool;
8 set_presence : [ `Online | `Offline | `Unavailable ] option;
9 timeout : int;
10}
11
12let default_params = {
13 filter = None;
14 since = None;
15 full_state = false;
16 set_presence = None;
17 timeout = 30000;
18}
19
20let presence_to_string = function
21 | `Online -> "online"
22 | `Offline -> "offline"
23 | `Unavailable -> "unavailable"
24
25let sync client ?(params = default_params) () =
26 let query = []
27 |> (fun q -> match params.filter with Some f -> ("filter", f) :: q | None -> q)
28 |> (fun q -> match params.since with Some s -> ("since", s) :: q | None -> q)
29 |> (fun q -> if params.full_state then ("full_state", "true") :: q else q)
30 |> (fun q -> match params.set_presence with Some p -> ("set_presence", presence_to_string p) :: q | None -> q)
31 |> (fun q -> ("timeout", string_of_int params.timeout) :: q)
32 in
33 let query = if query = [] then None else Some query in
34 match Client.get client ~path:"/sync" ?query () with
35 | Error e -> Error e
36 | Ok body -> Client.decode_response Matrix_proto.Sync.Response.jsont body
37
38(* Sync loop *)
39type action =
40 | Continue
41 | Stop
42 | Retry_after of int
43
44type callbacks = {
45 on_sync : Matrix_proto.Sync.Response.t -> action;
46 on_error : Error.t -> action;
47}
48
49let rec sync_loop client clock params callbacks since =
50 let params = { params with since } in
51 match sync client ~params () with
52 | Error e ->
53 (match callbacks.on_error e with
54 | Continue -> sync_loop client clock params callbacks since
55 | Stop -> ()
56 | Retry_after ms ->
57 Eio.Time.sleep clock (float_of_int ms /. 1000.0);
58 sync_loop client clock params callbacks since)
59 | Ok response ->
60 (match callbacks.on_sync response with
61 | Continue -> sync_loop client clock params callbacks (Some response.next_batch)
62 | Stop -> ()
63 | Retry_after ms ->
64 Eio.Time.sleep clock (float_of_int ms /. 1000.0);
65 sync_loop client clock params callbacks (Some response.next_batch))
66
67let sync_forever client ~clock ?initial_since ?(params = default_params) ~callbacks () =
68 sync_loop client clock params callbacks initial_since
69
70(* Filter types *)
71type event_filter = {
72 limit : int option;
73 not_senders : string list;
74 not_types : string list;
75 senders : string list;
76 types : string list;
77}
78
79type room_event_filter = {
80 limit : int option;
81 not_senders : string list;
82 not_types : string list;
83 senders : string list;
84 types : string list;
85 lazy_load_members : bool;
86 include_redundant_members : bool;
87 not_rooms : string list;
88 rooms : string list;
89 contains_url : bool option;
90}
91
92type room_filter = {
93 not_rooms : string list;
94 rooms : string list;
95 ephemeral : room_event_filter option;
96 include_leave : bool;
97 state : room_event_filter option;
98 timeline : room_event_filter option;
99 account_data : room_event_filter option;
100}
101
102type filter = {
103 event_fields : string list;
104 event_format : [ `Client | `Federation ];
105 presence : event_filter option;
106 account_data : event_filter option;
107 room : room_filter option;
108}
109
110let default_event_filter = {
111 limit = None;
112 not_senders = [];
113 not_types = [];
114 senders = [];
115 types = [];
116}
117
118let default_room_event_filter = {
119 limit = None;
120 not_senders = [];
121 not_types = [];
122 senders = [];
123 types = [];
124 lazy_load_members = true;
125 include_redundant_members = false;
126 not_rooms = [];
127 rooms = [];
128 contains_url = None;
129}
130
131let default_room_filter = {
132 not_rooms = [];
133 rooms = [];
134 ephemeral = None;
135 include_leave = false;
136 state = None;
137 timeline = None;
138 account_data = None;
139}
140
141let default_filter = {
142 event_fields = [];
143 event_format = `Client;
144 presence = None;
145 account_data = None;
146 room = None;
147}
148
149(* Filter JSON codecs *)
150let event_filter_jsont : event_filter Jsont.t =
151 let open Jsont.Object in
152 map (fun limit not_senders not_types senders types ->
153 ({ limit; not_senders; not_types; senders; types } : event_filter))
154 |> opt_mem "limit" Jsont.int ~enc:(fun (t : event_filter) -> t.limit)
155 |> mem "not_senders" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (t : event_filter) -> t.not_senders)
156 |> mem "not_types" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (t : event_filter) -> t.not_types)
157 |> mem "senders" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (t : event_filter) -> t.senders)
158 |> mem "types" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (t : event_filter) -> t.types)
159 |> finish
160
161let room_event_filter_jsont : room_event_filter Jsont.t =
162 let open Jsont.Object in
163 map (fun limit not_senders not_types senders types lazy_load_members
164 include_redundant_members not_rooms rooms contains_url ->
165 ({ limit; not_senders; not_types; senders; types; lazy_load_members;
166 include_redundant_members; not_rooms; rooms; contains_url } : room_event_filter))
167 |> opt_mem "limit" Jsont.int ~enc:(fun (t : room_event_filter) -> t.limit)
168 |> mem "not_senders" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (t : room_event_filter) -> t.not_senders)
169 |> mem "not_types" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (t : room_event_filter) -> t.not_types)
170 |> mem "senders" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (t : room_event_filter) -> t.senders)
171 |> mem "types" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (t : room_event_filter) -> t.types)
172 |> mem "lazy_load_members" Jsont.bool ~dec_absent:false ~enc:(fun (t : room_event_filter) -> t.lazy_load_members)
173 |> mem "include_redundant_members" Jsont.bool ~dec_absent:false ~enc:(fun (t : room_event_filter) -> t.include_redundant_members)
174 |> mem "not_rooms" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (t : room_event_filter) -> t.not_rooms)
175 |> mem "rooms" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (t : room_event_filter) -> t.rooms)
176 |> opt_mem "contains_url" Jsont.bool ~enc:(fun (t : room_event_filter) -> t.contains_url)
177 |> finish
178
179let room_filter_jsont : room_filter Jsont.t =
180 let open Jsont.Object in
181 map (fun not_rooms rooms ephemeral include_leave state timeline account_data ->
182 ({ not_rooms; rooms; ephemeral; include_leave; state; timeline; account_data } : room_filter))
183 |> mem "not_rooms" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (t : room_filter) -> t.not_rooms)
184 |> mem "rooms" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (t : room_filter) -> t.rooms)
185 |> opt_mem "ephemeral" room_event_filter_jsont ~enc:(fun (t : room_filter) -> t.ephemeral)
186 |> mem "include_leave" Jsont.bool ~dec_absent:false ~enc:(fun (t : room_filter) -> t.include_leave)
187 |> opt_mem "state" room_event_filter_jsont ~enc:(fun (t : room_filter) -> t.state)
188 |> opt_mem "timeline" room_event_filter_jsont ~enc:(fun (t : room_filter) -> t.timeline)
189 |> opt_mem "account_data" room_event_filter_jsont ~enc:(fun (t : room_filter) -> t.account_data)
190 |> finish
191
192let event_format_jsont : [ `Client | `Federation ] Jsont.t =
193 Jsont.of_of_string ~kind:"event_format"
194 ~enc:(function `Client -> "client" | `Federation -> "federation")
195 (function
196 | "client" -> Ok `Client
197 | "federation" -> Ok `Federation
198 | s -> Error ("Unknown event_format: " ^ s))
199
200let filter_jsont : filter Jsont.t =
201 let open Jsont.Object in
202 map (fun event_fields event_format presence account_data room ->
203 ({ event_fields; event_format; presence; account_data; room } : filter))
204 |> mem "event_fields" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun (t : filter) -> t.event_fields)
205 |> mem "event_format" event_format_jsont ~dec_absent:`Client ~enc:(fun (t : filter) -> t.event_format)
206 |> opt_mem "presence" event_filter_jsont ~enc:(fun (t : filter) -> t.presence)
207 |> opt_mem "account_data" event_filter_jsont ~enc:(fun (t : filter) -> t.account_data)
208 |> opt_mem "room" room_filter_jsont ~enc:(fun (t : filter) -> t.room)
209 |> finish
210
211(* Filter API *)
212type filter_response = {
213 filter_id : string;
214} [@@warning "-69"]
215
216let filter_response_jsont =
217 Jsont.Object.(
218 map (fun filter_id -> { filter_id })
219 |> mem "filter_id" Jsont.string
220 |> finish)
221
222let create_filter client ~filter =
223 match Client.user_id client with
224 | None -> Error (Error.Network_error "Not logged in")
225 | Some user_id ->
226 let user_id_str = Matrix_proto.Id.User_id.to_string user_id in
227 let path = Printf.sprintf "/user/%s/filter" user_id_str in
228 match Client.encode_body filter_jsont filter with
229 | Error e -> Error e
230 | Ok body ->
231 match Client.post client ~path ~body () with
232 | Error e -> Error e
233 | Ok body ->
234 match Client.decode_response filter_response_jsont body with
235 | Error e -> Error e
236 | Ok resp -> Ok resp.filter_id
237
238let get_filter client ~filter_id =
239 match Client.user_id client with
240 | None -> Error (Error.Network_error "Not logged in")
241 | Some user_id ->
242 let user_id_str = Matrix_proto.Id.User_id.to_string user_id in
243 let path = Printf.sprintf "/user/%s/filter/%s" user_id_str filter_id in
244 match Client.get client ~path () with
245 | Error e -> Error e
246 | Ok body -> Client.decode_response filter_jsont body