anil.recoil.org
Matrix protocol in OCaml, Eio specialised
1(** Space operations for Matrix spaces (MSC1772).
2
3 Spaces are special rooms with type "m.space" that contain child rooms
4 via m.space.child state events. *)
5
6(** Space hierarchy information *)
7type space_room = {
8 room_id : Matrix_proto.Id.Room_id.t;
9 name : string option;
10 topic : string option;
11 canonical_alias : Matrix_proto.Id.Room_alias.t option;
12 avatar_url : string option;
13 num_joined_members : int;
14 room_type : string option;
15 join_rule : Matrix_proto.Event.Join_rule.t option;
16 children_state : child_state list;
17 world_readable : bool;
18 guest_can_join : bool;
19}
20
21and child_state = {
22 state_key : string;
23 via : string list;
24 order : string option;
25 suggested : bool;
26}
27
28let child_state_jsont =
29 Jsont.Object.(
30 map (fun state_key via order suggested ->
31 { state_key; via; order; suggested })
32 |> mem "state_key" Jsont.string ~enc:(fun t -> t.state_key)
33 |> mem "via" (Jsont.list Jsont.string) ~dec_absent:[] ~enc:(fun t -> t.via)
34 |> opt_mem "order" Jsont.string ~enc:(fun t -> t.order)
35 |> mem "suggested" Jsont.bool ~dec_absent:false ~enc:(fun t -> t.suggested)
36 |> finish)
37
38let space_room_jsont =
39 Jsont.Object.(
40 map (fun room_id name topic canonical_alias avatar_url num_joined_members
41 room_type join_rule children_state world_readable guest_can_join ->
42 { room_id; name; topic; canonical_alias; avatar_url; num_joined_members;
43 room_type; join_rule; children_state; world_readable; guest_can_join })
44 |> mem "room_id" Matrix_proto.Id.Room_id.jsont ~enc:(fun t -> t.room_id)
45 |> opt_mem "name" Jsont.string ~enc:(fun t -> t.name)
46 |> opt_mem "topic" Jsont.string ~enc:(fun t -> t.topic)
47 |> opt_mem "canonical_alias" Matrix_proto.Id.Room_alias.jsont ~enc:(fun t -> t.canonical_alias)
48 |> opt_mem "avatar_url" Jsont.string ~enc:(fun t -> t.avatar_url)
49 |> mem "num_joined_members" Jsont.int ~dec_absent:0 ~enc:(fun t -> t.num_joined_members)
50 |> opt_mem "room_type" Jsont.string ~enc:(fun t -> t.room_type)
51 |> opt_mem "join_rule" Matrix_proto.Event.Join_rule.jsont ~enc:(fun t -> t.join_rule)
52 |> mem "children_state" (Jsont.list child_state_jsont) ~dec_absent:[]
53 ~enc:(fun t -> t.children_state)
54 |> mem "world_readable" Jsont.bool ~dec_absent:false ~enc:(fun t -> t.world_readable)
55 |> mem "guest_can_join" Jsont.bool ~dec_absent:false ~enc:(fun t -> t.guest_can_join)
56 |> finish)
57
58(** Response from [GET /_matrix/client/v1/rooms/\{roomId\}/hierarchy]. *)
59type hierarchy_response = {
60 rooms : space_room list;
61 next_batch : string option;
62}
63
64let hierarchy_response_jsont =
65 Jsont.Object.(
66 map (fun rooms next_batch -> { rooms; next_batch })
67 |> mem "rooms" (Jsont.list space_room_jsont) ~dec_absent:[] ~enc:(fun t -> t.rooms)
68 |> opt_mem "next_batch" Jsont.string ~enc:(fun t -> t.next_batch)
69 |> finish)
70
71(** Get the hierarchy of a space.
72
73 @param room_id The space room ID
74 @param suggested_only If true, only return suggested rooms
75 @param limit Maximum number of rooms to return per request
76 @param max_depth Maximum depth to recurse into the hierarchy
77 @param from Pagination token *)
78let get_hierarchy client ~room_id ?suggested_only ?limit ?max_depth ?from () =
79 let room_id_str = Matrix_proto.Id.Room_id.to_string room_id in
80 let path = Printf.sprintf "/rooms/%s/hierarchy" (Uri.pct_encode room_id_str) in
81 let query =
82 []
83 |> (fun q -> match suggested_only with
84 | Some true -> ("suggested_only", "true") :: q
85 | _ -> q)
86 |> (fun q -> match limit with
87 | Some l -> ("limit", string_of_int l) :: q
88 | None -> q)
89 |> (fun q -> match max_depth with
90 | Some d -> ("max_depth", string_of_int d) :: q
91 | None -> q)
92 |> (fun q -> match from with
93 | Some f -> ("from", f) :: q
94 | None -> q)
95 in
96 let query = if query = [] then None else Some query in
97 match Client.get client ~path ?query () with
98 | Error e -> Error e
99 | Ok body -> Client.decode_response hierarchy_response_jsont body
100
101(** Add a child room to a space.
102
103 @param space_id The parent space room ID
104 @param child_id The child room ID
105 @param via Server names to route through
106 @param order Optional ordering string
107 @param suggested Whether the room is suggested *)
108(* Response type for state setting *)
109type set_state_response = {
110 event_id : Matrix_proto.Id.Event_id.t;
111}
112
113let set_state_response_jsont =
114 Jsont.Object.(
115 map (fun event_id -> { event_id })
116 |> mem "event_id" Matrix_proto.Id.Event_id.jsont
117 |> finish)
118
119let add_child client ~space_id ~child_id ?(via = []) ?order ?(suggested = false) () =
120 let space_id_str = Matrix_proto.Id.Room_id.to_string space_id in
121 let child_id_str = Matrix_proto.Id.Room_id.to_string child_id in
122 let path = Printf.sprintf "/rooms/%s/state/m.space.child/%s"
123 (Uri.pct_encode space_id_str)
124 (Uri.pct_encode child_id_str)
125 in
126 let content : Matrix_proto.Event.Space_child_content.t = {
127 via = if via = [] then None else Some via;
128 order;
129 suggested = if suggested then Some true else None;
130 } in
131 match Client.encode_body Matrix_proto.Event.Space_child_content.jsont content with
132 | Error e -> Error e
133 | Ok body ->
134 match Client.put client ~path ~body () with
135 | Error e -> Error e
136 | Ok resp_body ->
137 match Client.decode_response set_state_response_jsont resp_body with
138 | Error e -> Error e
139 | Ok resp -> Ok resp.event_id
140
141(** Remove a child room from a space. *)
142let remove_child client ~space_id ~child_id =
143 let space_id_str = Matrix_proto.Id.Room_id.to_string space_id in
144 let child_id_str = Matrix_proto.Id.Room_id.to_string child_id in
145 let path = Printf.sprintf "/rooms/%s/state/m.space.child/%s"
146 (Uri.pct_encode space_id_str)
147 (Uri.pct_encode child_id_str)
148 in
149 (* Send empty content to remove the child *)
150 match Client.put client ~path ~body:"{}" () with
151 | Error e -> Error e
152 | Ok _ -> Ok ()
153
154(** Set the parent space for a room.
155
156 @param room_id The child room ID
157 @param parent_id The parent space ID
158 @param via Server names to route through
159 @param canonical Whether this is the canonical parent *)
160let set_parent client ~room_id ~parent_id ?(via = []) ?(canonical = false) () =
161 let room_id_str = Matrix_proto.Id.Room_id.to_string room_id in
162 let parent_id_str = Matrix_proto.Id.Room_id.to_string parent_id in
163 let path = Printf.sprintf "/rooms/%s/state/m.space.parent/%s"
164 (Uri.pct_encode room_id_str)
165 (Uri.pct_encode parent_id_str)
166 in
167 let content : Matrix_proto.Event.Space_parent_content.t = {
168 via = if via = [] then None else Some via;
169 canonical = if canonical then Some true else None;
170 } in
171 match Client.encode_body Matrix_proto.Event.Space_parent_content.jsont content with
172 | Error e -> Error e
173 | Ok body ->
174 match Client.put client ~path ~body () with
175 | Error e -> Error e
176 | Ok resp_body ->
177 match Client.decode_response set_state_response_jsont resp_body with
178 | Error e -> Error e
179 | Ok resp -> Ok resp.event_id
180
181(** Remove a parent space from a room. *)
182let remove_parent client ~room_id ~parent_id =
183 let room_id_str = Matrix_proto.Id.Room_id.to_string room_id in
184 let parent_id_str = Matrix_proto.Id.Room_id.to_string parent_id in
185 let path = Printf.sprintf "/rooms/%s/state/m.space.parent/%s"
186 (Uri.pct_encode room_id_str)
187 (Uri.pct_encode parent_id_str)
188 in
189 match Client.put client ~path ~body:"{}" () with
190 | Error e -> Error e
191 | Ok _ -> Ok ()
192
193(** Check if a room is a space. *)
194let is_space room_type =
195 match room_type with
196 | Some "m.space" -> true
197 | _ -> false
198
199(** Create a new space.
200
201 @param name The space name
202 @param topic Optional topic
203 @param visibility Room visibility (public or private)
204 @param invite List of users to invite *)
205let create_space client ~name ?topic ?(visibility = `Private) ?(invite = []) () =
206 Rooms.create_room client
207 ~name
208 ?topic
209 ~visibility
210 ~invite
211 ~room_type:"m.space"
212 ()