diff options
| -rw-r--r-- | lib/sasl.ml | 32 | ||||
| -rw-r--r-- | test/hello.ml | 7 |
2 files changed, 20 insertions, 19 deletions
diff --git a/lib/sasl.ml b/lib/sasl.ml index 2241a91..4bd80cc 100644 --- a/lib/sasl.ml +++ b/lib/sasl.ml @@ -1,4 +1,3 @@ -open Lwt.Syntax open Lwt.Infix open Stream @@ -56,28 +55,29 @@ let send_auth_stanza (stream, push) localpart pass mechanism = try Xml.get stream >|= parse_sasl_response with exn -> Lwt.fail exn -let authenticate (portal : Portal.t) ({jid; password; preferred_mechanisms} : auth_config) = +let authenticate + (portal : Portal.t) + ({jid; password; preferred_mechanisms} : auth_config) + (sasl_mechanisms : Stream.auth_mechanism list) = (* 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" + and preferred, not_preferred = + List.partition (fun f -> List.exists ((=) f) preferred_mechanisms) sasl_mechanisms in - let* {mechanisms; _} = Xml.get (fst portal) >|= Stream.parse_features - in let preferred, not_preferred = - List.partition (fun f -> List.exists ((=) f) preferred_mechanisms) 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) + (* 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. + (* This is a particularly shameful hack: This auth result will always be retried. TODO: make something less unstable. *) |> Lwt_seq.fold_left_s try_auth (Error (MalformedRequest, None)) diff --git a/test/hello.ml b/test/hello.ml index 5bc38ad..392c3a1 100644 --- a/test/hello.ml +++ b/test/hello.ml @@ -2,8 +2,8 @@ open! Lwt.Syntax open! Lwt.Infix open! Flesh -let program (stream, push) config = - let+ _auth = Sasl.authenticate (stream, push) config +let program (stream, push) config (features : Stream.features) = + let+ _auth = Sasl.authenticate (stream, push) config features.mechanisms in begin match _auth with | Error (NotAuthorized, Some (_, text)) -> print_endline ("Not authorized: " ^ text) | Error (MalformedRequest, Some (_, text)) -> print_endline ("Malformed request: " ^ text) @@ -21,8 +21,9 @@ let main = in let domain = (List.nth (String.split_on_char '@' config.jid) 1) in let* stream, push = Portal.connect domain in let* _id = Portal.header domain (stream, push) in + let* features = Xml.get stream >|= Stream.parse_features in Lwt.catch - (fun () -> program (stream, push) config >|= (fun () -> push None)) + (fun () -> program (stream, push) config features >|= (fun () -> push None)) (fun exn -> push None; (* I suspect JavaScript's [wrap_callback] swallows the Exceptions thrown by |