diff options
| -rw-r--r-- | lib/auth.ml | 26 | ||||
| -rw-r--r-- | test/js/websockets_hello.ml | 5 |
2 files changed, 28 insertions, 3 deletions
diff --git a/lib/auth.ml b/lib/auth.ml index d97a8cb..aa533a0 100644 --- a/lib/auth.ml +++ b/lib/auth.ml @@ -1,3 +1,5 @@ +open Lwt.Syntax + type auth_mechanism = PLAIN [@@deriving show { with_path = false }] type sasl_error = @@ -7,9 +9,27 @@ let read_sasl_error = function | "not-authorized" -> NotAuthorized | _ -> 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) + | _ -> 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"), @@ -18,5 +38,7 @@ let send_auth_stanza (stream, push) jid pass mechanism = `Text [gen_auth mechanism]; `End_element] in Markup.(stanza_list |> of_list |> write_xml |> to_string) |> Option.some |> push; - (* TODO: use stream result for exceptions, etc. *) - Lwt_stream.get stream + let* response = Lwt_stream.get stream + in try + Option.get response |> parse_sasl_response |> Lwt.return + with exn -> Lwt.fail exn diff --git a/test/js/websockets_hello.ml b/test/js/websockets_hello.ml index 8af5a5e..9043501 100644 --- a/test/js/websockets_hello.ml +++ b/test/js/websockets_hello.ml @@ -21,7 +21,10 @@ let main (stream, push) = in let+ _auth = Auth.send_auth_stanza (stream, push) "test@example.com" "password" Auth.PLAIN - in push None + in push None; + match _auth with + | Error (NotAuthorized, Some ("en", text)) -> print_endline text + | _ -> () let () = run @@ |