diff options
| -rw-r--r-- | lib/stream.ml | 14 | ||||
| -rw-r--r-- | test/hello.ml | 14 |
2 files changed, 14 insertions, 14 deletions
diff --git a/lib/stream.ml b/lib/stream.ml index 4bc0901..0ea7850 100644 --- a/lib/stream.ml +++ b/lib/stream.ml @@ -57,16 +57,12 @@ let parse_features (stanza : Xml.element) : features = This function should be called every time a stream needs to be reopened and stream negotiation takes place. - When the XMPP server advertises optional STARTTLS support, whether the connection - will be upgraded to STARTTLS depends on [prefer_starttls]. - Basically, it conforms to {{: https://datatracker.ietf.org/doc/html/rfc6120#section-4.3 }}. *) let negotiate - ?(prefer_starttls = true) (domain : string) (portal : Portal.t) - (auth : Sasl.config) : features Lwt.t = + (config : config) : features Lwt.t = (* Test if a specific features mandates a restart of the stream. *) let needs_restart = function | Mechanisms _ | STARTTLS -> true @@ -80,7 +76,7 @@ let negotiate (* Handle a single feature. Mandatory is whether the feature is mandatory. *) let handle_feature (mandatory : bool) (f : feature) : unit Lwt.t = let handle_starttls () = - if (mandatory || prefer_starttls) + if (mandatory || config.starttls.prefer_starttls) then Starttls.upgrade portal else Lwt.return_unit and handle_mechanisms mechanisms = @@ -94,7 +90,7 @@ let negotiate | _ -> "Unknown error!" in if allow_auth () then - let* auth_result = authenticate portal auth mechanisms + 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 @@ -117,9 +113,9 @@ let negotiate Once [None] is pushed into the stream, the receiving stream is drained and the socket is closed. *) -let initiate (domain : string) (auth : Sasl.config) : (Portal.t * features) Lwt.t = +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 auth + in let+ features = negotiate domain p config in (p, features) diff --git a/test/hello.ml b/test/hello.ml index 097e750..e506ded 100644 --- a/test/hello.ml +++ b/test/hello.ml @@ -3,12 +3,16 @@ open! Lwt.Infix open! Flesh let main = - let config : Sasl.config = { - jid = (Sys.getenv "FLESH_JID"); - password = (Sys.getenv "FLESH_PASSWORD"); - preferred_mechanisms = [Sasl.PLAIN] + let config : Stream.config = { + starttls = {prefer_starttls = true}; + sasl = { + jid = (Sys.getenv "FLESH_JID"); + password = (Sys.getenv "FLESH_PASSWORD"); + preferred_mechanisms = [Sasl.PLAIN] + }; + other = []; } - in let domain = (List.nth (String.split_on_char '@' config.jid) 1) in + 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) with exn -> begin |