1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
open Lwt.Infix
open Stream
open Markup
type auth_config = {
jid : string;
password : string;
preferred_mechanisms : auth_mechanism list;
}
type sasl_error =
| NotAuthorized
| MalformedRequest
let parse_sasl_error = function
| "not-authorized" -> NotAuthorized
| "malformed-request" -> MalformedRequest
| _ -> failwith "Unsupported SASL error returned by the server."
type sasl_auth = (string option, sasl_error * (string * string) option) result
let send_auth_stanza (stream, push) localpart pass mechanism =
let gen_auth = function
| PLAIN -> Base64.encode_exn ("\x00" ^ localpart ^ "\x00" ^ pass)
| Unknown s -> failwith "Unsupported authentication mechanism " ^ s
and parse_sasl_response (signal : (signal, sync) stream) =
let stanza : Xml.element =
match Xml.tree signal with
| None -> raise (InvalidStanza (signal |> write_xml |> to_string))
| Some s -> s
in
let nsless = match stanza with
| {
namespace = "urn:ietf:params:xml:ns:xmpp-sasl";
attributes = [];
local_name;
children=rest;
} -> (local_name, rest)
| _ -> raise (InvalidStanza (Xml.element_to_string stanza))
in
let open Either in
let parse_descriptive_text (s : (Xml.element, string) t list) =
let to_lang = List.find_map (function ("lang", lang) -> Some lang | _ -> None)
in match s with
| [Left {local_name="text"; attributes; children=[Right desc]; _}] ->
Some (Option.value (to_lang attributes) ~default:"en", desc)
| _ -> None
in match nsless with
| ("success", []) -> Ok None
| ("success", [Right rest]) -> Ok (Some rest)
| ("failure", [Left {local_name=error; children; _}]) ->
Error (parse_sasl_error error, parse_descriptive_text children)
| _ -> raise (InvalidStanza (Xml.element_to_string stanza))
in let stanza_list = [`Start_element
((Xmlns.sasl, "auth"),
[(("", "xmlns"), Xmlns.sasl);
(("", "mechanism"), show_auth_mechanism mechanism)]);
`Text [gen_auth mechanism];
`End_element]
in Some (Markup.of_list stanza_list) |> push;
try get stream >|= parse_sasl_response
with exn -> Lwt.fail exn
let authenticate (portal : Portal.t) (config : auth_config) =
let {jid; password; _} = config
(* Probably not exactly compliant with https://xmpp.org/extensions/xep-0029.html,
but it's just for simplicity's sake in alpha. *)
in let localpart = match String.split_on_char '@' jid with
| [localpart; _domain] -> localpart
| _ -> failwith "Invalid JID"
in send_auth_stanza portal localpart password PLAIN
|
