diff options
| -rw-r--r-- | lib/stream.ml | 19 | ||||
| -rw-r--r-- | lib/xml.ml | 14 | ||||
| -rw-r--r-- | portal/tcp/portal_tcp.ml | 8 | ||||
| -rw-r--r-- | portal/ws/portal.ml | 61 |
4 files changed, 50 insertions, 52 deletions
diff --git a/lib/stream.ml b/lib/stream.ml index 4781161..21c134d 100644 --- a/lib/stream.ml +++ b/lib/stream.ml @@ -18,10 +18,9 @@ type stream_features = { unknown_features : Xml.element list; } +(** [next stream] is a promise containing a full stanza of the fragments of + [stream]. *) let next (stream : (signal, async) stream) : (signal, sync) stream Lwt.t = - (** [next stream] is a promise containing a full stanza of the fragments of - [stream]. *) - let traverse_stanza depth fragment = let depth = match fragment with | `Start_element _ -> depth + 1 @@ -30,18 +29,18 @@ let next (stream : (signal, async) stream) : (signal, sync) stream Lwt.t = in ([fragment], if depth = 0 then None else Some depth) in transform traverse_stanza 0 stream |> Markup_lwt.load +(** [get stream] is a promise containing a single Xml element of [stream]. *) let get (stream : (signal, async) stream) : Xml.element Lwt.t = - (** [get stream] is a promise containing a single Xml element of [stream]. *) let* signal = next stream in match Xml.tree signal with | Some xml -> Lwt.return xml | None -> Lwt.fail (InvalidStanza (signal |> write_xml |> to_string)) -let start domain : Portal.t Lwt.t = - (** [start domain] is a promise containing a Portal (stream * push) connected to the - XMPP server [domain]. +(** [start domain] is a promise containing a Portal (stream * push) connected to the + XMPP server [domain]. - Currently, it doesn't handle anything except the initial [<open/>] stanza. *) + Currently, it doesn't handle anything except the initial [<open/>] stanza. *) +let start domain : Portal.t Lwt.t = let* stream, _push = Portal.connect domain in let push = function | None -> _push (Some Portal.stanza_close); @@ -52,9 +51,9 @@ let start domain : Portal.t Lwt.t = let+ _ = get stream in stream, push +(** [parse_features el] is a [stream_features] record with all the features of the + [<stream:features>] stanza contained in [el]. *) let parse_features (el : Xml.element) : stream_features = - (** [parse_features el] is a [stream_features] record with all the features of the - [<stream:features>] stanza contained in [el]. *) let open Xml in let open Either in let parse_mechanism_stanza = function @@ -7,9 +7,9 @@ type element = { children : (element, string) Either.t list; } +(** [tree s] is an [element option] representing the XML element inside of stream [s], + if [s] is a complete element from start to end. *) let tree s : element option = - (** [tree s] is an [element option] representing the XML element inside of stream [s], - if [s] is a complete element from start to end. *) let element (namespace, name) attributes children = Either.Left { namespace; @@ -27,12 +27,12 @@ let tree s : element option = let opt_el = tree ~text ~element s in Option.bind opt_el (Either.fold ~left:Option.some ~right:(fun _ -> None)) -let element_to_string ?(indent = 2) (el : element) = - (** [element_to_string element] is a string representation of the underlying XML in - [element], for debugging purposes. +(** [element_to_string element] is a string representation of the underlying XML in + [element], for debugging purposes. - Note this isn't serialization: namely, XML namespaces are inferred and don't exist - in the actual [element]. *) + Note this isn't serialization: namely, XML namespaces are inferred and don't exist + in the actual [element]. *) +let element_to_string ?(indent = 2) (el : element) = let rec element_to_string parent {local_name; attributes; children; namespace} = let attributes = (if parent == namespace then "" else " xmlns=\"" ^ namespace ^ "\"") ^ diff --git a/portal/tcp/portal_tcp.ml b/portal/tcp/portal_tcp.ml index cfe35dd..3aa5e56 100644 --- a/portal/tcp/portal_tcp.ml +++ b/portal/tcp/portal_tcp.ml @@ -1,8 +1,8 @@ -let xmpp_port (_domain : string) : int = 5222 - (** [xmpp_port domain] is the port where [domain]'s XMPP server is hosted. +(** [xmpp_port domain] is the port where [domain]'s XMPP server is hosted. - Currently, it falls back to 5222 (always), but should use SRV records in the near - future. *) + Currently, it falls back to 5222 (always), but should use SRV records in the near + future. *) +let xmpp_port (_domain : string) : int = 5222 let connect (domain : string) = xmpp_port domain |> string_of_int |> print_endline diff --git a/portal/ws/portal.ml b/portal/ws/portal.ml index 2916e66..916fd2f 100644 --- a/portal/ws/portal.ml +++ b/portal/ws/portal.ml @@ -13,11 +13,10 @@ let xmlns = "urn:ietf:params:xml:ns:xmpp-framing" rules. *) let well_known_of (domain : string) = "https://" ^ domain ^ "/.well-known/host-meta" -let stanza_open ?from domain : (signal, sync) stream = - (** [open_stanza domain] is an <open /> stanza for [domain]. +(** [open_stanza domain] is an <open /> stanza for [domain]. - If [from] is specified, the <open /> stanza has the from parameter. - *) + If [from] is specified, the <open /> stanza has the from parameter. *) +let stanza_open ?from domain : (signal, sync) stream = let open Markup in let stanza = let attributes = @@ -37,16 +36,16 @@ let stanza_close = {|<close xmlns="|} ^ xmlns ^ {|" />|} |> string |> parse_xml exception MalformedStanza of Markup.location * Markup.Error.t -let ws_endpoint (domain : string) : string Lwt.t = - (** [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 ws_endpoint (domain : string) : string Lwt.t = let open Markup in (* This ugly function extracts the href element from a Link tag's attributes if it's a websocket. *) @@ -72,16 +71,16 @@ let ws_endpoint (domain : string) : string Lwt.t = | Some x -> Lwt.return x | None -> Lwt.fail_with (domain ^ ": no WebSocket endpoint in 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. + Pushing [None] closes the websocket. - If the websocket is closed server-side, the stream closes. *) + If the websocket is closed server-side, the stream closes. *) +let ws_stream (url : string) = let open Lwt_stream in let stream, message = create () in let open Lwt_condition in @@ -96,21 +95,21 @@ let ws_stream (url : string) = 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] 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 -> \ - function user websocket - \ <--- stream <--- markup_lwt <--- ws_stream <--- / *) + Here's an ASCII rendered flow of the data through the various streams. + / -> push -> mu_stream -> to_frames -> ws_push -> \ + function user websocket + \ <--- stream <--- markup_lwt <--- ws_stream <--- / *) +let connect domain = 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 |