diff options
Diffstat (limited to 'lib/sasl.ml')
| -rw-r--r-- | lib/sasl.ml | 55 |
1 files changed, 31 insertions, 24 deletions
diff --git a/lib/sasl.ml b/lib/sasl.ml index 9b9f1fd..8206309 100644 --- a/lib/sasl.ml +++ b/lib/sasl.ml @@ -1,5 +1,6 @@ -open Lwt.Syntax +open Lwt.Infix open Stream +open Markup type auth_config = { jid : string; @@ -22,27 +23,34 @@ 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 (stanza : Markup.signal list) = - let open Markup in - let string_stanza = stanza |> of_list |> write_xml |> to_string 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 + 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 parse_error_stanza = function - | `Start_element ((_, error), _) :: `End_element :: rest -> - (parse_sasl_error error, parse_descriptive_text rest) - | _ -> raise (InvalidStanza string_stanza) - in match stanza with - | `Start_element ((_, "success"), _) :: rest -> Ok (parse_additional_info rest) - | `Start_element ((_, "failure"), _) :: rest -> Error (parse_error_stanza rest) - | _ -> raise (InvalidStanza string_stanza) + 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); @@ -50,9 +58,8 @@ let send_auth_stanza (stream, push) localpart pass mechanism = `Text [gen_auth mechanism]; `End_element] in Some (Markup.of_list stanza_list) |> push; - let* response = get stream - in try Markup.to_list response |> parse_sasl_response |> Lwt.return - with exn -> Lwt.fail exn + try get stream >|= parse_sasl_response + with exn -> Lwt.fail exn let authenticate (portal : Portal.t) (config : auth_config) = let {jid; password; _} = config |