feat(stream): detach sasl negotiation from main function

1 files changed, 22 insertions, 18 deletions

diff --git a/lib/stream.ml b/lib/stream.ml
index 362b3ee..5eaba42 100644
--- a/lib/stream.ml
+++ b/lib/stream.ml
@@ -59,6 +59,26 @@ let starttls mandatory portal {starttls=config; _} =
   then Starttls.upgrade portal
   else Lwt.return_unit
 
+(** [sasl mechanisms _mandatory portal config] authenticates using SASL with the XMPP
+    server [portal], following the stream config [config].
+
+    [_mandatory] has no effect (SASL negotiation is always mandatory, if present). *)
+let sasl mechanisms _ (portal : Portal.t) {sasl=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
 (** [negotiate domain portal auth] is a promise containing the features supported by the
     XMPP server [portal], after eventual STARTTLS negotiation and authentication using
     the auth config [auth].
@@ -84,25 +104,9 @@ let negotiate
   in
   (* Handle a single feature. Mandatory is whether the feature is mandatory. *)
   let handle_feature (mandatory : bool) (f : feature) : unit Lwt.t =
-    let handle_mechanisms 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 config.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 f with
+    match f with
     | STARTTLS -> starttls mandatory portal config
-    | Mechanisms m -> handle_mechanisms m
+    | Mechanisms m -> sasl m mandatory portal config
     | _ -> Lwt.return_unit
   in
   let rec handle_features (f : features) : features Lwt.t =