blob: 03882b4f29ad12b4f509880eb863625cb66618b8 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
module Stream = Stream
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 open Stream in
let* portal = connect domain
in
let needs_restart = function
| Feature.Mechanisms _ | STARTTLS -> true
| _ -> false
in
let+ features =
let rec handle_features (features : Stream.features) : Stream.features Lwt.t =
match features with
| feature :: rest ->
let* () = negotiate feature portal config
in if needs_restart (Feature.unwrap feature)
then start domain portal >>= handle_features
else handle_features rest
| features -> Lwt.return features
in start domain portal >>= handle_features
in (portal, features)
|
