diff options
| -rw-r--r-- | lib/stream.ml | 48 |
1 files changed, 23 insertions, 25 deletions
diff --git a/lib/stream.ml b/lib/stream.ml index 535fe99..e790980 100644 --- a/lib/stream.ml +++ b/lib/stream.ml @@ -50,33 +50,31 @@ let parse_features (stanza : Xml.element) : features = | [], [STARTTLS] -> [STARTTLS], [] | _ -> features -(** [authenticate mechanisms _mandatory portal config] authenticates using SASL with the - XMPP server [portal], following the stream config [config]. *) -let authenticate mechanisms (portal : Portal.t) config = - let open Sasl in - let allow_auth () = - Portal._encrypted portal._socket || - Option.is_some (Sys.getenv_opt "FLESH_ALLOW_STRIPTLS") - and parse_auth_error = function - | NotAuthorized, Some (_, text) -> "Not authorized: " ^ text - | MalformedRequest, Some (_, text) -> "Malformed request: " ^ text - | _ -> "Unknown error!" - in - if allow_auth () then - let* auth_result = authenticate portal config mechanisms - in match auth_result with - | Error err -> Lwt.fail_with (parse_auth_error err) - | Ok _ -> print_endline "Success!"; Lwt.return_unit - else Lwt.fail InsufficientEncryption - let negotiate_feature (mandatory : bool) (feat : feature) (portal : Portal.t) ({starttls; sasl; _} : config) : unit Lwt.t = - match feat with - | STARTTLS -> if mandatory || starttls.prefer_starttls - then Starttls.upgrade portal - else Lwt.return_unit - | Mechanisms mechs -> authenticate mechs portal sasl - | _ -> Lwt.return_unit + (* authenticate using SASL with the XMPP server. *) + let authenticate mechanisms = + let open Sasl in + let allow_auth () = + Portal._encrypted portal._socket || + Option.is_some (Sys.getenv_opt "FLESH_ALLOW_STRIPTLS") + and parse_auth_error = function + | NotAuthorized, Some (_, text) -> "Not authorized: " ^ text + | MalformedRequest, Some (_, text) -> "Malformed request: " ^ text + | _ -> "Unknown error!" + in + if allow_auth () then + let* auth_result = authenticate portal sasl mechanisms + in match auth_result with + | Error err -> Lwt.fail_with (parse_auth_error err) + | Ok _ -> print_endline "Success!"; Lwt.return_unit + else Lwt.fail InsufficientEncryption + in match feat with + | STARTTLS -> if mandatory || starttls.prefer_starttls + then Starttls.upgrade portal + else Lwt.return_unit + | Mechanisms mechs -> authenticate mechs + | _ -> Lwt.return_unit (** [negotiate domain portal auth] is a promise containing the features supported by the XMPP server [portal], after eventual STARTTLS negotiation and authentication using |