From 8b73d84b8f9bd5c8563e25470e319d464b5c2a6d Mon Sep 17 00:00:00 2001 From: Clombrong Date: Wed, 25 Jun 2025 00:50:08 +0200 Subject: feat(sasl): add features parsing to authenticate --- lib/sasl.ml | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) (limited to 'lib/sasl.ml') 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)) + -- cgit v1.2.3