diff options
Diffstat (limited to 'portal')
| -rw-r--r-- | portal/lib/ws/portal.ml | 31 |
1 files changed, 14 insertions, 17 deletions
diff --git a/portal/lib/ws/portal.ml b/portal/lib/ws/portal.ml index 620a238..d8afab3 100644 --- a/portal/lib/ws/portal.ml +++ b/portal/lib/ws/portal.ml @@ -68,30 +68,27 @@ let ws_endpoint (domain : string) = | None -> failwith (domain ^ "doesn't advertise a WebSocket endpoint via Web-host Metadata.") let ws_stream (url : string) = - (** [ws_stream url] returns a framed Lwt stream (and its push function) communicating with the websocket located at - [url] using the XMPP protocol.Lwt + (** [ws_stream url] is a promise to a framed Lwt stream (and its push function) communicating with the websocket + located at [url] using the XMPP protocol. Valid XMPP WebSocket subprotocol frames must be sent to the stream, because it directly exposes the websocket under. Pushing [None] closes the websocket. - If the websocket is closed server-side, it's still up to the caller to close the stream. *) + If the websocket is closed server-side, the stream closes. *) let open Lwt_stream in - let handle ws incoming () = - let+ _ = iter (fun msg -> ws##send (jss msg)) incoming - in (ws##close) - in let stream, message = create () (* websocket -> user *) - and incoming, push = create () (* user -> websocket *) - in let (ws : WebSockets.webSocket Js.t) = new%js WebSockets.webSocket_withProtocol (jss url) (jss "xmpp") - in ws##.onmessage := - Dom.handler (fun x -> Some (sjs x##.data) |> message; Js._false); - ws##.onopen := - Dom.handler (fun _ -> Lwt.async @@ handle ws incoming; Js._false); - ws##.onclose := - Dom.handler (fun _ -> message None; Js._true); - stream, push - + let stream, message = create () in + let open Lwt_condition in + let is_open = create () in + let (ws : WebSockets.webSocket Js.t) = new%js WebSockets.webSocket_withProtocol (jss url) (jss "xmpp") + in let push = function + | Some msg -> ws##send (jss msg) + | None -> ws##close + in ws##.onclose := Dom.handler (fun _ -> message None; Js._true); + ws##.onmessage := Dom.handler (fun x -> Some (sjs x##.data) |> message; Js._false); + ws##.onopen := Dom.handler (fun _ -> signal is_open (); Js._false); + let+ () = wait is_open in stream, push let connect domain = (** [connect domain] is an Lwt stream (and its push function) communicating with the XMPP server running at [domain] |