feat(session): refactor session state

session state is closer to the protocol

2 files changed, 21 insertions, 20 deletions

diff --git a/lib/session.ml b/lib/session.ml
index 756df82..2b399d9 100644
--- a/lib/session.ml
+++ b/lib/session.ml
@@ -3,15 +3,16 @@ open Lwt.Infix
 open Lwt_react
 open Stream
 
-type connection_step =
+type step =
   | Starting_stream
   | Negotiating_feature of Feature.requirement * features
+  | Logged_in of features
 
 type state =
   | Disconnected
-  | Opening_portal of string
-  | Connecting of Portal.t * connection_step
-  | Connected of Portal.t * features
+  | Connecting of string
+  (* TCP/WebSocket connected, not connected in XMPP-land *)
+  | Connected of Portal.t * step
 
 (** [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.
@@ -25,31 +26,31 @@ let create (domain : string) (config : config) : (state signal * (unit -> unit))
   let needs_restart = function
     | Feature.Mechanisms _ | STARTTLS -> true
     | _ -> false
-  and features_next_state portal = function
-    | feature :: rest -> Connecting (portal, Negotiating_feature (feature, rest))
+  and features_next_state = function
+    | feature :: rest -> Negotiating_feature (feature, rest)
     (* No features returned by stream start. Connection is completed. *)
-    | [] -> Connected (portal, [])
+    | [] -> Logged_in []
   and 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
+    | Connected (_, step1), Connected (_, step2) -> step1 = step2
     | _ -> s1 = s2
   in
   let state, update = S.create ~eq Disconnected in
   let+ () = S.map_s
               (function
-               | Opening_portal domain ->
+               | Connecting domain ->
                   let+ portal = Portal.connect domain
-                  in update (Connecting (portal, Starting_stream))
-               | Connecting (portal, Starting_stream) ->
+                  in update (Connected (portal, Starting_stream))
+               | Connected (portal, Starting_stream) ->
                   let+ features = Stream.start domain portal
-                  in features_next_state portal features |> update
-               | Connecting (portal, Negotiating_feature (feature, features)) ->
+                  in let next_state = features_next_state features
+                     in update (Connected (portal, next_state))
+               | Connected (portal, Negotiating_feature (feature, features)) ->
                   let+ () = negotiate feature portal config
                   in let next_state = if needs_restart (Feature.unwrap feature)
-                                      then Connecting (portal, Starting_stream)
-                                      else features_next_state portal features
-                     in update next_state
+                                      then Starting_stream
+                                      else features_next_state features
+                     in update (Connected (portal, next_state))
                | _ -> Lwt.return_unit)
               state >|= S.keep;
-  in state, fun () -> update (Opening_portal domain)
+  in state, fun () -> update (Connecting domain)
diff --git a/test/hello.ml b/test/hello.ml
index f4661c3..c7bf46e 100644
--- a/test/hello.ml
+++ b/test/hello.ml
@@ -18,8 +18,8 @@ let main =
   let waiter, wakener = Lwt.wait () in
   try%lwt let* state, connect = create config.sasl.jid.domainpart config in
              S.map (function
-                 | Connected (portal, _) -> portal.push None;
-                                            Lwt.wakeup wakener ()
+                 | Connected (portal, Logged_in _) -> portal.push None;
+                                                      Lwt.wakeup wakener ()
                  | _ -> ())
                state |> S.keep;
              connect ();