diff options
| -rw-r--r-- | lib/flesh.ml | 30 | ||||
| -rw-r--r-- | lib/stream.ml | 35 | ||||
| -rw-r--r-- | test/hello.ml | 2 |
3 files changed, 31 insertions, 36 deletions
diff --git a/lib/flesh.ml b/lib/flesh.ml index c6ab079..51f1b6c 100644 --- a/lib/flesh.ml +++ b/lib/flesh.ml @@ -3,3 +3,33 @@ module Sasl = Sasl module Starttls = Starttls module Wire = Wire module Xml = Xml + +open Lwt.Syntax +open Lwt.Infix + +(** [connect domain config] is a promise containing the portal connected to the XMPP + server located at [domain], and all its supported features. + + Basically, it conforms to {{: + https://datatracker.ietf.org/doc/html/rfc6120#section-4.3 }}, and gets the provided + Portal in a "ready" state. *) +let connect (domain : string) (config : Stream.config) : (Portal.t * Stream.features) Lwt.t = + let open Portal in + let* portal = connect domain + in + let needs_restart = function + | Stream.Mechanisms _ | STARTTLS -> true + | _ -> false + in + let+ features = + let rec handle_features (features : Stream.features) : Stream.features Lwt.t = + match features with + | feature :: mandatory, optional -> + let* () = Stream.negotiate_feature true feature portal config + in if needs_restart feature + then Stream.start domain portal >>= handle_features + else handle_features (mandatory, optional) + | features -> Lwt.return features + in Stream.start domain portal >>= handle_features + in (portal, features) + diff --git a/lib/stream.ml b/lib/stream.ml index 6b46ed6..cc5ad92 100644 --- a/lib/stream.ml +++ b/lib/stream.ml @@ -81,38 +81,3 @@ let negotiate_feature (mandatory : bool) (feat : feature) (portal : Portal.t) 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 - the auth config [auth]. - - This function should be called every time a stream needs to be reopened and stream - negotiation takes place. - - Basically, it conforms to - {{: https://datatracker.ietf.org/doc/html/rfc6120#section-4.3 }}. *) -let negotiate - (domain : string) - (portal : Portal.t) - (config : config) : features Lwt.t = - (* Test if a specific features mandates a restart of the stream. *) - let needs_restart = function - | Mechanisms _ | STARTTLS -> true - | _ -> false - in - let rec handle_features (f : features) : features Lwt.t = - match f with - | m :: mandatory, optional -> let* () = negotiate_feature true m portal config - in if needs_restart m - then start domain portal >>= handle_features - else handle_features (mandatory, optional) - | [], _ -> Lwt.return f - in start domain portal >>= handle_features - -(** [initiate domain] initiates a stream with the XMPP server [domain]. *) -let initiate (domain : string) (config : config) : (Portal.t * features) Lwt.t = - let open Portal in - let* p = connect domain - in let+ features = negotiate domain p config - in (p, features) - diff --git a/test/hello.ml b/test/hello.ml index e506ded..51468dd 100644 --- a/test/hello.ml +++ b/test/hello.ml @@ -13,7 +13,7 @@ let main = other = []; } in let domain = (List.nth (String.split_on_char '@' config.sasl.jid) 1) in - try%lwt Stream.initiate domain config >|= (fun (portal, _) -> portal.push None) + try%lwt connect domain config >|= (fun (portal, _) -> portal.push None) with exn -> begin (* I suspect JavaScript's [wrap_callback] swallows the Exceptions thrown by |