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
|
open Lwt.Syntax
type auth_mechanism = PLAIN [@@deriving show { with_path = false }]
type sasl_error =
| NotAuthorized
| MalformedRequest
let read_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) jid pass mechanism =
let gen_auth = function
| PLAIN -> Base64.encode_exn ("\x00" ^ jid ^ "\x00" ^ pass)
and parse_sasl_response stanza =
let open Markup in
let parse_additional_info = function
| `Text t :: _ -> Some (String.concat "" t)
| _ -> None
and parse_descriptive_text = function
| `Start_element ((_, "text"), [((_, "lang"), lang)]) :: `Text desc :: _ -> Some (lang, String.concat "" desc)
| `Start_element ((_, "text"), []) :: `Text desc :: _ -> Some ("en", String.concat "" desc)
| _ -> None
in
let parse_sasl_error = function
| `Start_element ((_, error), _) :: `End_element :: rest -> (read_sasl_error error, parse_descriptive_text rest)
| _ -> raise (Stream.InvalidStanza stanza)
in match (string stanza |> parse_xml |> signals |> to_list) with
| `Start_element ((_, "success"), _) :: rest -> Ok (parse_additional_info rest)
| `Start_element ((_, "failure"), _) :: rest -> Error (parse_sasl_error rest)
| _ -> raise (Stream.InvalidStanza stanza)
in let xmlns = "urn:ietf:params:xml:ns:xmpp-sasl" in
let stanza_list = [`Start_element
((xmlns, "auth"),
[(("", "xmlns"), xmlns);
(("", "mechanism"), show_auth_mechanism mechanism)]);
`Text [gen_auth mechanism];
`End_element]
in Markup.(stanza_list |> of_list |> write_xml |> to_string) |> Option.some |> push;
let* response = Lwt_stream.get stream
in try
Option.get response |> parse_sasl_response |> Lwt.return
with exn -> Lwt.fail exn
|
