1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
open Lwt.Syntax
open Lwt.Infix
open Js_of_ocaml
open Markup
let jss = Js.string
let sjs = Js.to_string
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. *)
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].
If [from] is specified, the <open /> stanza has the from parameter.
*)
let open Markup in
let stanza =
let attributes =
let open Option in
[(("", "xmlns"), xmlns);
(("", "to"), domain)]
@ (map (fun jid -> (("", "from"), jid)) from |> to_list)
@ [(("", "version"), "1.0")]
in
[`Start_element
((xmlns, "open"),
attributes);
`End_element]
in stanza |> of_list
let stanza_close = {|<close xmlns="|} ^ xmlns ^ {|" />|} |> string |> parse_xml |> signals
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.
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. *)
let open Markup in
(* 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") :: _
-> Some href
| _ -> None
in let parse_xrd xrd =
string xrd
|> parse_xml
|> signals
|> tree ~element:(fun (_, name) attributes children ->
match name with
| "Link" -> link_websocket attributes
| "XRD" -> List.find_map (fun x -> x) children
| _ -> None
)
|> Option.join
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.")
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.
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, the stream closes. *)
let open Lwt_stream in
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]
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.
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 <--- / *)
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. *)
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. *)
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 chomp_fragment depth fragment =
let depth = match fragment with
| `Start_element _ -> depth + 1
| `End_element -> depth - 1
| _ -> depth
in stanza := fragment :: !stanza;
total_depth := depth;
(if depth = 0 then let s = [stanza_to_string stanza] in stanza := []; s else []), Some depth
in let push = function
| None -> ws_push None
| Some fragment ->
Lwt.async
(fun () -> content fragment
|> Markup.transform chomp_fragment !total_depth
|> Markup_lwt.to_lwt_stream
|> Lwt_stream.iter (fun s -> ws_push (Some s)))
in ws_stream |> lwt_stream |> strings_to_bytes |> parse_xml ~report |> signals, push
|
