diff options
Diffstat (limited to 'lib/sasl.ml')
| -rw-r--r-- | lib/sasl.ml | 13 |
1 files changed, 7 insertions, 6 deletions
diff --git a/lib/sasl.ml b/lib/sasl.ml index 088543b..608d6fd 100644 --- a/lib/sasl.ml +++ b/lib/sasl.ml @@ -22,8 +22,9 @@ 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) - and parse_sasl_response stanza = + 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 @@ -34,11 +35,11 @@ let send_auth_stanza (stream, push) localpart pass mechanism = 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 + | _ -> raise (Stream.InvalidStanza (stanza |> of_list |> write_xml |> to_string)) + in match stanza with | `Start_element ((_, "success"), _) :: rest -> Ok (parse_additional_info rest) | `Start_element ((_, "failure"), _) :: rest -> Error (parse_sasl_error rest) - | _ -> raise (Stream.InvalidStanza stanza) + | _ -> raise (Stream.InvalidStanza string_stanza) in let xmlns = "urn:ietf:params:xml:ns:xmpp-sasl" in let stanza_list = [`Start_element ((xmlns, "auth"), @@ -46,9 +47,9 @@ let send_auth_stanza (stream, push) localpart pass mechanism = (("", "mechanism"), show_auth_mechanism mechanism)]); `Text [gen_auth mechanism]; `End_element] - in Markup.(stanza_list |> of_list |> write_xml |> to_string) |> Option.some |> push; + in Some (Markup.of_list stanza_list) |> push; let* response = Stream.get stream - in try parse_sasl_response response |> Lwt.return + in try Markup.to_list response |> parse_sasl_response |> Lwt.return with exn -> Lwt.fail exn let authenticate (portal : Portal.t) (config : auth_config) = |