feat(sasl): add features parsing to authenticate

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))
+