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
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
|
open Lwt.Syntax
open Lwt.Infix
open Lwt_react
type connection_step =
| Starting_stream of string
| Negotiating_features of Stream.features
type state =
| Disconnected
| Opening_portal of string
| Connecting of Portal.t * connection_step
| Connected of Portal.t * Stream.features
(** [create domain config] is a promise containing a signal representing the portal
connected to the XMPP server located at [domain], and all its supported features.
When calling the function, the portal will try to connect to the provided domain.
Basically, it conforms to {{:
https://datatracker.ietf.org/doc/html/rfc6120#section-4.3 }}, and gets the Portal in
a "ready" state. *)
let create (domain : string) (config : Stream.config) : (state signal * (unit -> unit)) Lwt.t =
let eq s1 s2 = (* TODO: move this closer to the state type *)
match s1, s2 with
| Connecting (_, step1), Connecting (_, step2) -> step1 = step2
| Connected (_, f1), Connected (_, f2) -> f1 = f2
| _ -> s1 = s2
in
let state, update = S.create ~eq Disconnected in
let connect (portal : Portal.t) (_features : Stream.features) : unit Lwt.t =
let open Stream 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 handle_features _features
in update (Connected (portal, features))
in
let+ () = S.map_s
(function
| Opening_portal domain ->
let+ portal = Portal.connect domain
in update (Connecting (portal, Starting_stream domain))
| Connecting (portal, Starting_stream domain) ->
let+ features = Stream.start domain portal
in update (Connecting (portal, Negotiating_features features))
| Connecting (portal, Negotiating_features features) ->
connect portal features
| _ -> Lwt.return_unit)
state >|= S.keep;
in state, fun () -> update (Opening_portal domain)
|
