diff options
Diffstat (limited to 'portal/lib/ws/portal.ml')
| -rw-r--r-- | portal/lib/ws/portal.ml | 60 |
1 files changed, 36 insertions, 24 deletions
diff --git a/portal/lib/ws/portal.ml b/portal/lib/ws/portal.ml index 0be0d81..3fd142a 100644 --- a/portal/lib/ws/portal.ml +++ b/portal/lib/ws/portal.ml @@ -9,7 +9,8 @@ type t = (signal, async) stream * ((signal, sync) stream option -> unit) let xmlns = "urn:ietf:params:xml:ns:xmpp-framing" -(* sic. XEP-0156: "host-meta files MUST be fetched only over HTTPS". I don't make the rules. *) +(* sic. XEP-0156: "host-meta files MUST be fetched only over HTTPS". I don't make the + rules. *) let well_known_of (domain : string) = "https://" ^ domain ^ "/.well-known/host-meta" let stanza_open ?from domain : (signal, sync) stream = @@ -37,15 +38,18 @@ let stanza_close = {|<close xmlns="|} ^ xmlns ^ {|" />|} |> string |> parse_xml exception MalformedStanza of Markup.location * Markup.Error.t let ws_endpoint (domain : string) = - (** [ws_endpoint domain] is a promise containing the XMPP websocket endpoint associated with [domain], by using the - domain's Web-host Metadata. + (** [ws_endpoint domain] is a promise containing the XMPP websocket endpoint + associated with [domain], by using the domain's Web-host Metadata. - This function uses XMLHttpRequest, so while it should work fine in the browser, in environments that don't provide - this constructor (Node.js), there should be some sort of polyfill. + This function uses XMLHttpRequest, so while it should work fine in the browser, in + environments that don't provide this constructor (Node.js), there should be some + sort of polyfill. - Lastly, if [domain] doesn't provide a well-formed Web-host Metadata file, the function throws an exception. *) + Lastly, if [domain] doesn't provide a well-formed Web-host Metadata file, the + function throws an exception. *) let open Markup in - (* This ugly function extracts the href element from a Link tag's attributes if it's a websocket. *) + (* This ugly function extracts the href element from a Link tag's attributes if it's a + websocket. *) let link_websocket = function | ((_, "rel"), "urn:xmpp:alt-connections:websocket") :: ((_, "href"), href) :: _ | ((_, "href"), href) :: ((_, "rel"), "urn:xmpp:alt-connections:websocket") :: _ @@ -62,17 +66,18 @@ let ws_endpoint (domain : string) = | _ -> None ) |> Option.join - in let+ host_meta = Js_of_ocaml_lwt.XmlHttpRequest.perform_raw_url (well_known_of domain) + in let+ host_meta = + Js_of_ocaml_lwt.XmlHttpRequest.perform_raw_url (well_known_of domain) in match parse_xrd host_meta.content with - | Some x -> x - | None -> failwith (domain ^ "doesn't advertise a WebSocket endpoint via Web-host Metadata.") + | Some x -> x + | None -> failwith (domain ^ "doesn't advertise a WebSocket endpoint via Web-host Metadata.") let ws_stream (url : string) = - (** [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. + (** [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. + Valid XMPP WebSocket subprotocol frames must be sent to the stream, because it + directly exposes the websocket under. Pushing [None] closes the websocket. @@ -81,7 +86,8 @@ let ws_stream (url : string) = 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") + 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 @@ -91,13 +97,15 @@ let ws_stream (url : string) = 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] - via the Websocket subprotocol. + (** [connect domain] is an Lwt stream (and its push function) communicating with the + XMPP server running at [domain] via the Websocket subprotocol. - This function is a complex wrapper around ws_stream, that accepts Markup.ml signals and sends framed XML stanzas - to the underlying socket, with exactly one stanza per frame, according to RFC 7935. + This function is a complex wrapper around ws_stream, that accepts Markup.ml + signals and sends framed XML stanzas to the underlying socket, with exactly one + stanza per frame, according to RFC 7935. - In essence, it (tries to) expose an identical interface to the original XMPP streamed protocol. + In essence, it (tries to) expose an identical interface to the original XMPP + streamed protocol. Here's an ASCII rendered flow of the data through the various streams. / -> push -> mu_stream -> to_frames -> ws_push -> \ @@ -105,15 +113,19 @@ let connect domain = \ <--- stream <--- markup_lwt <--- ws_stream <--- / *) let+ ws_stream, ws_push = ws_endpoint domain >>= ws_stream in let open Markup_lwt in - (* When sending a malformed stanza (one that Markup.ml doesn't like), a MalformedStanza exception is raised. *) + (* When sending a malformed stanza (one that Markup.ml doesn't like), a + MalformedStanza exception is raised. *) let report loc err = raise (MalformedStanza (loc, err)) in - (* Consumes a stream of Markup.ml signals into a series of frames sent to the WebSocket. *) + (* Consumes a stream of Markup.ml signals into a series of frames sent to the + WebSocket. *) let stanza = ref [] in let total_depth = ref 0 in - let stanza_to_string stanza = Markup.(!stanza |> List.rev |> of_list |> write_xml |> to_string) in - (* Consume a single fragment, and add it to the "stanza" ref if it's not complete -- as soon as it's completed, send it. *) + let stanza_to_string stanza = + Markup.(!stanza |> List.rev |> of_list |> write_xml |> to_string) in + (* Consume a single fragment, and add it to the "stanza" ref if it's not complete -- + as soon as it's completed, send it. *) let chomp_fragment depth fragment = let depth = match fragment with | `Start_element _ -> depth + 1 |