anil.recoil.org
Matrix protocol in OCaml, Eio specialised
1(** User-Interactive Authentication API (UIAA).
2
3 UIAA is Matrix's mechanism for protecting sensitive operations that require
4 additional verification beyond just an access token. Operations like:
5 - Deleting devices
6 - Changing passwords
7 - Adding 3PIDs
8 - Deactivating accounts
9
10 When these operations return a 401 with UIAA challenge, clients must
11 complete authentication stages before the operation can proceed. *)
12
13(** Authentication stage types *)
14type auth_type =
15 | Password
16 | Recaptcha
17 | OAuth2
18 | Email_identity
19 | Msisdn (* Phone number *)
20 | Dummy
21 | Registration_token
22 | Terms
23 | Sso
24 | Sso_fallback
25 | Custom of string
26
27let auth_type_of_string = function
28 | "m.login.password" -> Password
29 | "m.login.recaptcha" -> Recaptcha
30 | "m.login.oauth2" -> OAuth2
31 | "m.login.email.identity" -> Email_identity
32 | "m.login.msisdn" -> Msisdn
33 | "m.login.dummy" -> Dummy
34 | "m.login.registration_token" -> Registration_token
35 | "m.login.terms" -> Terms
36 | "m.login.sso" -> Sso
37 | "org.matrix.login.sso.fallback" -> Sso_fallback
38 | s -> Custom s
39
40let auth_type_to_string = function
41 | Password -> "m.login.password"
42 | Recaptcha -> "m.login.recaptcha"
43 | OAuth2 -> "m.login.oauth2"
44 | Email_identity -> "m.login.email.identity"
45 | Msisdn -> "m.login.msisdn"
46 | Dummy -> "m.login.dummy"
47 | Registration_token -> "m.login.registration_token"
48 | Terms -> "m.login.terms"
49 | Sso -> "m.login.sso"
50 | Sso_fallback -> "org.matrix.login.sso.fallback"
51 | Custom s -> s
52
53(** Authentication flow - a sequence of stages that must be completed *)
54type auth_flow = {
55 stages : auth_type list;
56}
57
58(* Internal type for JSON parsing *)
59type auth_flow_json = {
60 stages_json : string list;
61}
62
63let auth_flow_jsont =
64 let json_type =
65 Jsont.Object.(
66 map (fun stages_json -> { stages_json })
67 |> mem "stages" (Jsont.list Jsont.string) ~dec_absent:[]
68 ~enc:(fun t -> t.stages_json)
69 |> finish)
70 in
71 Jsont.map
72 ~dec:(fun flow -> { stages = List.map auth_type_of_string flow.stages_json })
73 ~enc:(fun flow -> { stages_json = List.map auth_type_to_string flow.stages })
74 json_type
75
76(** UIAA response from server when authentication is required *)
77type uiaa_response = {
78 session : string option;
79 flows : auth_flow list;
80 completed : auth_type list;
81 params : Jsont.json option;
82 error : string option;
83 errcode : string option;
84}
85
86(* Internal type for JSON parsing *)
87type uiaa_response_json = {
88 session_json : string option;
89 flows_json : auth_flow list;
90 completed_json : string list;
91 params_json : Jsont.json option;
92 error_json : string option;
93 errcode_json : string option;
94}
95
96let uiaa_response_jsont =
97 let json_type =
98 Jsont.Object.(
99 map (fun session_json flows_json completed_json params_json error_json errcode_json ->
100 { session_json; flows_json; completed_json; params_json; error_json; errcode_json })
101 |> opt_mem "session" Jsont.string ~enc:(fun t -> t.session_json)
102 |> mem "flows" (Jsont.list auth_flow_jsont) ~dec_absent:[] ~enc:(fun t -> t.flows_json)
103 |> mem "completed" (Jsont.list Jsont.string) ~dec_absent:[]
104 ~enc:(fun t -> t.completed_json)
105 |> opt_mem "params" Jsont.json ~enc:(fun t -> t.params_json)
106 |> opt_mem "error" Jsont.string ~enc:(fun t -> t.error_json)
107 |> opt_mem "errcode" Jsont.string ~enc:(fun t -> t.errcode_json)
108 |> finish)
109 in
110 Jsont.map
111 ~dec:(fun r -> {
112 session = r.session_json;
113 flows = r.flows_json;
114 completed = List.map auth_type_of_string r.completed_json;
115 params = r.params_json;
116 error = r.error_json;
117 errcode = r.errcode_json;
118 })
119 ~enc:(fun r -> {
120 session_json = r.session;
121 flows_json = r.flows;
122 completed_json = List.map auth_type_to_string r.completed;
123 params_json = r.params;
124 error_json = r.error;
125 errcode_json = r.errcode;
126 })
127 json_type
128
129(** Authentication data to send in response to UIAA challenge *)
130type auth_data =
131 | Password_auth of {
132 identifier : user_identifier;
133 password : string;
134 session : string option;
135 }
136 | Recaptcha_auth of {
137 response : string;
138 session : string option;
139 }
140 | Email_identity_auth of {
141 threepid_creds : threepid_creds;
142 session : string option;
143 }
144 | Msisdn_auth of {
145 threepid_creds : threepid_creds;
146 session : string option;
147 }
148 | Dummy_auth of {
149 session : string option;
150 }
151 | Token_auth of {
152 token : string;
153 session : string option;
154 }
155 | Terms_auth of {
156 session : string option;
157 }
158
159and user_identifier =
160 | User of string (* user_id *)
161 | ThirdParty of { medium : string; address : string }
162 | Phone of { country : string; phone : string }
163
164and threepid_creds = {
165 sid : string;
166 client_secret : string;
167 id_server : string option;
168 id_access_token : string option;
169}
170
171(** Encode user identifier to JSON *)
172let user_identifier_to_json = function
173 | User user_id ->
174 Printf.sprintf {|{"type":"m.id.user","user":"%s"}|} user_id
175 | ThirdParty { medium; address } ->
176 Printf.sprintf {|{"type":"m.id.thirdparty","medium":"%s","address":"%s"}|}
177 medium address
178 | Phone { country; phone } ->
179 Printf.sprintf {|{"type":"m.id.phone","country":"%s","phone":"%s"}|}
180 country phone
181
182(** Encode auth data to JSON object for request body *)
183let auth_data_to_json = function
184 | Password_auth { identifier; password; session } ->
185 let session_part = match session with
186 | Some s -> Printf.sprintf {|,"session":"%s"|} s
187 | None -> ""
188 in
189 Printf.sprintf {|{"type":"m.login.password","identifier":%s,"password":"%s"%s}|}
190 (user_identifier_to_json identifier)
191 password
192 session_part
193 | Recaptcha_auth { response; session } ->
194 let session_part = match session with
195 | Some s -> Printf.sprintf {|,"session":"%s"|} s
196 | None -> ""
197 in
198 Printf.sprintf {|{"type":"m.login.recaptcha","response":"%s"%s}|}
199 response session_part
200 | Email_identity_auth { threepid_creds = creds; session } ->
201 let session_part = match session with
202 | Some s -> Printf.sprintf {|,"session":"%s"|} s
203 | None -> ""
204 in
205 let id_server_part = match creds.id_server with
206 | Some s -> Printf.sprintf {|,"id_server":"%s"|} s
207 | None -> ""
208 in
209 let id_token_part = match creds.id_access_token with
210 | Some s -> Printf.sprintf {|,"id_access_token":"%s"|} s
211 | None -> ""
212 in
213 Printf.sprintf
214 {|{"type":"m.login.email.identity","threepid_creds":{"sid":"%s","client_secret":"%s"%s%s}%s}|}
215 creds.sid creds.client_secret id_server_part id_token_part session_part
216 | Msisdn_auth { threepid_creds = creds; session } ->
217 let session_part = match session with
218 | Some s -> Printf.sprintf {|,"session":"%s"|} s
219 | None -> ""
220 in
221 let id_server_part = match creds.id_server with
222 | Some s -> Printf.sprintf {|,"id_server":"%s"|} s
223 | None -> ""
224 in
225 let id_token_part = match creds.id_access_token with
226 | Some s -> Printf.sprintf {|,"id_access_token":"%s"|} s
227 | None -> ""
228 in
229 Printf.sprintf
230 {|{"type":"m.login.msisdn","threepid_creds":{"sid":"%s","client_secret":"%s"%s%s}%s}|}
231 creds.sid creds.client_secret id_server_part id_token_part session_part
232 | Dummy_auth { session } ->
233 let session_part = match session with
234 | Some s -> Printf.sprintf {|,"session":"%s"|} s
235 | None -> ""
236 in
237 Printf.sprintf {|{"type":"m.login.dummy"%s}|} session_part
238 | Token_auth { token; session } ->
239 let session_part = match session with
240 | Some s -> Printf.sprintf {|,"session":"%s"|} s
241 | None -> ""
242 in
243 Printf.sprintf {|{"type":"m.login.registration_token","token":"%s"%s}|}
244 token session_part
245 | Terms_auth { session } ->
246 let session_part = match session with
247 | Some s -> Printf.sprintf {|,"session":"%s"|} s
248 | None -> ""
249 in
250 Printf.sprintf {|{"type":"m.login.terms"%s}|} session_part
251
252(** Result of a UIAA operation *)
253type 'a uiaa_result =
254 | Uiaa_success of 'a
255 | Uiaa_auth_required of uiaa_response
256 | Uiaa_error of Error.t
257
258(** Check if a response is a UIAA challenge (401 with flows) *)
259let is_uiaa_response status_code body =
260 status_code = 401 &&
261 String.length body > 0 &&
262 (String.contains body 'f' && String.contains body 'l') (* Quick check for "flows" *)
263
264(** Parse a UIAA response from error body *)
265let parse_uiaa_response body =
266 match Jsont_bytesrw.decode_string uiaa_response_jsont body with
267 | Ok r -> Some r
268 | Error _ -> None
269
270(** Create password authentication data *)
271let password_auth ~user_id ~password ?session () =
272 Password_auth {
273 identifier = User user_id;
274 password;
275 session;
276 }
277
278(** Create dummy authentication (for flows that allow it) *)
279let dummy_auth ?session () =
280 Dummy_auth { session }
281
282(** Create recaptcha authentication *)
283let recaptcha_auth ~response ?session () =
284 Recaptcha_auth { response; session }
285
286(** Create email identity authentication *)
287let email_identity_auth ~sid ~client_secret ?id_server ?id_access_token ?session () =
288 Email_identity_auth {
289 threepid_creds = { sid; client_secret; id_server; id_access_token };
290 session;
291 }
292
293(** Create registration token authentication *)
294let token_auth ~token ?session () =
295 Token_auth { token; session }
296
297(** Create terms acceptance authentication *)
298let terms_auth ?session () =
299 Terms_auth { session }
300
301(** Find the simplest flow to complete (fewest stages) *)
302let find_simplest_flow uiaa =
303 match uiaa.flows with
304 | [] -> None
305 | flows ->
306 Some (List.fold_left (fun acc flow ->
307 if List.length flow.stages < List.length acc.stages then flow else acc
308 ) (List.hd flows) flows)
309
310(** Check if a flow contains only the given auth types *)
311let flow_contains_only flow types =
312 List.for_all (fun stage -> List.mem stage types) flow.stages
313
314(** Check if password-only auth is available *)
315let has_password_only_flow uiaa =
316 List.exists (fun flow ->
317 flow_contains_only flow [Password] ||
318 flow_contains_only flow [Password; Dummy]
319 ) uiaa.flows
320
321(** Check if dummy auth is available (often used in development) *)
322let has_dummy_flow uiaa =
323 List.exists (fun flow ->
324 flow_contains_only flow [Dummy]
325 ) uiaa.flows
326
327(** Get the remaining stages to complete *)
328let remaining_stages uiaa flow =
329 List.filter (fun stage -> not (List.mem stage uiaa.completed)) flow.stages
330
331(** UIAA-protected request wrapper.
332
333 This function handles the UIAA flow automatically:
334 1. Makes the initial request
335 2. If 401 with UIAA, calls the auth_callback to get auth data
336 3. Retries the request with auth data
337 4. Repeats until success or failure *)
338let with_uiaa ~make_request ~auth_callback =
339 match make_request None with
340 | Ok result -> Uiaa_success result
341 | Error e ->
342 (* Check if this is a UIAA challenge *)
343 match e with
344 | Error.Http_error { status = 401; body; _ } ->
345 (match parse_uiaa_response body with
346 | Some uiaa ->
347 (* Get auth data from callback *)
348 (match auth_callback uiaa with
349 | Some auth_data ->
350 (* Retry with auth *)
351 (match make_request (Some (auth_data_to_json auth_data)) with
352 | Ok result -> Uiaa_success result
353 | Error e2 ->
354 (* Check for another UIAA challenge (multi-stage) *)
355 (match e2 with
356 | Error.Http_error { status = 401; body = body2; _ } ->
357 (match parse_uiaa_response body2 with
358 | Some uiaa2 -> Uiaa_auth_required uiaa2
359 | None -> Uiaa_error e2)
360 | _ -> Uiaa_error e2))
361 | None ->
362 Uiaa_auth_required uiaa)
363 | None -> Uiaa_error e)
364 | _ -> Uiaa_error e
365
366(** Helper to add auth field to a request body *)
367let add_auth_to_body body auth_json =
368 if String.length body < 2 then
369 Printf.sprintf {|{"auth":%s}|} auth_json
370 else
371 (* Insert auth field into existing JSON object *)
372 let trimmed = String.trim body in
373 if String.get trimmed 0 = '{' then
374 let content = String.sub trimmed 1 (String.length trimmed - 2) in
375 if String.length (String.trim content) = 0 then
376 Printf.sprintf {|{"auth":%s}|} auth_json
377 else
378 Printf.sprintf {|{"auth":%s,%s}|} auth_json (String.trim content)
379 else
380 body
381
382(** Verify email for 3PID binding.
383 First step: request token to be sent to email *)
384type request_token_response = {
385 sid : string;
386 submit_url : string option;
387}
388
389let request_token_response_jsont =
390 Jsont.Object.(
391 map (fun sid submit_url -> { sid; submit_url })
392 |> mem "sid" Jsont.string ~enc:(fun t -> t.sid)
393 |> opt_mem "submit_url" Jsont.string ~enc:(fun t -> t.submit_url)
394 |> finish)
395
396(** Request a token for email validation *)
397let request_email_token client ~email ~client_secret ~send_attempt ?next_link () =
398 let path = "/account/3pid/email/requestToken" in
399 let next_link_part = match next_link with
400 | Some nl -> Printf.sprintf {|,"next_link":"%s"|} nl
401 | None -> ""
402 in
403 let body = Printf.sprintf
404 {|{"client_secret":"%s","email":"%s","send_attempt":%d%s}|}
405 client_secret email send_attempt next_link_part
406 in
407 match Client.post client ~path ~body () with
408 | Error e -> Error e
409 | Ok resp_body -> Client.decode_response request_token_response_jsont resp_body
410
411(** Request a token for phone number validation *)
412let request_msisdn_token client ~country ~phone_number ~client_secret ~send_attempt ?next_link () =
413 let path = "/account/3pid/msisdn/requestToken" in
414 let next_link_part = match next_link with
415 | Some nl -> Printf.sprintf {|,"next_link":"%s"|} nl
416 | None -> ""
417 in
418 let body = Printf.sprintf
419 {|{"client_secret":"%s","country":"%s","phone_number":"%s","send_attempt":%d%s}|}
420 client_secret country phone_number send_attempt next_link_part
421 in
422 match Client.post client ~path ~body () with
423 | Error e -> Error e
424 | Ok resp_body -> Client.decode_response request_token_response_jsont resp_body
425
426(** Validate a token (submit to identity server or homeserver) *)
427let validate_email_token client ~sid ~client_secret ~token =
428 let path = "/account/3pid/email/validate" in
429 let body = Printf.sprintf
430 {|{"sid":"%s","client_secret":"%s","token":"%s"}|}
431 sid client_secret token
432 in
433 match Client.post client ~path ~body () with
434 | Error e -> Error e
435 | Ok _ -> Ok ()