diff options
| -rw-r--r-- | lib/session.ml | 11 | ||||
| -rw-r--r-- | test/hello.ml | 18 |
2 files changed, 21 insertions, 8 deletions
diff --git a/lib/session.ml b/lib/session.ml index 5b61346..7534433 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1,5 +1,6 @@ open Lwt.Syntax open Lwt.Infix +open Lwt_react type state = | Disconnected @@ -32,3 +33,13 @@ let connect (domain : string) (config : Stream.config) : (Portal.t * Stream.feat | features -> Lwt.return features in start domain portal >>= handle_features in (portal, features) + +let create (domain : string) (config : Stream.config) : (state signal * (unit -> unit)) Lwt.t = + let state, update = S.create Disconnected in + let+ () = S.map_s + (function + | Connecting -> let+ portal, features = connect domain config + in update (Connected (portal, features)) + | _ -> Lwt.return_unit) + state >|= S.keep; + in state, (fun () -> update Connecting) diff --git a/test/hello.ml b/test/hello.ml index dd06554..f4661c3 100644 --- a/test/hello.ml +++ b/test/hello.ml @@ -2,6 +2,7 @@ open! Lwt.Syntax open! Lwt.Infix open! Flesh open! Session +open! Lwt_react let main = let config : Stream.config = { @@ -14,14 +15,15 @@ let main = other = []; } in - let state, update = Lwt_react.S.create Disconnected in - Lwt_react.S.map (function - | Disconnected -> print_endline "Disconnected" - | Connecting -> print_endline "Connecting" - | Connected (portal, _) -> portal.push None) - state |> ignore; - try%lwt connect config.sasl.jid.domainpart config >|= - (fun (portal, state) -> update (Connected (portal, state))) + 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 () + | _ -> ()) + state |> S.keep; + connect (); + waiter with exn -> begin (* I suspect JavaScript's [wrap_callback] swallows the Exceptions thrown by |