diff options
| -rw-r--r-- | lib/sasl.ml | 22 |
1 files changed, 19 insertions, 3 deletions
diff --git a/lib/sasl.ml b/lib/sasl.ml index f5a5ae0..b4d4929 100644 --- a/lib/sasl.ml +++ b/lib/sasl.ml @@ -57,12 +57,28 @@ let send_auth_stanza (stream, push) localpart pass mechanism = with exn -> Lwt.fail exn let authenticate (portal : Portal.t) (config : auth_config) = - let {jid; password; _} = config in + let {jid; password; preferred_mechanisms} = config in (* Probably not exactly compliant with https://xmpp.org/extensions/xep-0029.html, but it's just for simplicity's sake in alpha. *) let localpart = match String.split_on_char '@' jid with | [localpart; _domain] -> localpart | _ -> failwith "Invalid JID" in - let* _features = Stream.get (fst portal) >|= Stream.parse_features - in send_auth_stanza portal localpart password PLAIN + let* {sasl_mechanisms; _} = Stream.get (fst portal) >|= Stream.parse_features + in let preferred, not_preferred = + List.partition (fun f -> List.exists ((=) f) preferred_mechanisms) sasl_mechanisms + in + (* Function that takes a [sasl_auth] and returns whether this attempt should be + retried, or is definitive (e.g, success or bad credentials). *) + let definitive = function + | Ok _ -> true + | Error (sasl, _) -> unrecoverable sasl + in let try_auth acc sasl = + if definitive acc + then Lwt.return acc + else (send_auth_stanza portal localpart password sasl) + in Lwt_seq.of_list (preferred @ not_preferred) + (* This is a particularly shameful hack: This auth will always be retried. + TODO: make something less unstable. *) + |> Lwt_seq.fold_left_s try_auth (Error (MalformedRequest, None)) + |