diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/portal/dune | 2 | ||||
| -rw-r--r-- | lib/portal/portal_ws.ml | 42 |
2 files changed, 39 insertions, 5 deletions
diff --git a/lib/portal/dune b/lib/portal/dune index 47b59ce..8ce0232 100644 --- a/lib/portal/dune +++ b/lib/portal/dune @@ -2,5 +2,5 @@ (name portal_ws) (modules portal_ws) (public_name flesh_websockets) - (libraries lwt js_of_ocaml) + (libraries lwt js_of_ocaml js_of_ocaml-lwt xmlm) (preprocess (pps js_of_ocaml-ppx))) diff --git a/lib/portal/portal_ws.ml b/lib/portal/portal_ws.ml index f2c0cf5..c6dbf81 100644 --- a/lib/portal/portal_ws.ml +++ b/lib/portal/portal_ws.ml @@ -1,13 +1,47 @@ open Lwt.Syntax - open Js_of_ocaml let jss = Js.string let sjs = Js.to_string -let lwt_ws (url : string) = - (** [lwt_ws url] returns a stream and a push function for the websocket at [url]. +(* 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 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+ host_meta = Js_of_ocaml_lwt.XmlHttpRequest.perform_raw_url (well_known_of domain) + in let i = Xmlm.make_input (`String (0, host_meta.content)) + (* This ugly function extracts the href element from a Link tag's attributes if it's a websocket. *) + and link_websocket attrs = + match attrs with + | ((_, "href"), href) :: ((_, "rel"), "urn:xmpp:alt-connections:websocket") :: _ -> Some href + | ((_, "rel"), "urn:xmpp:alt-connections:websocket") :: ((_, "href"), href) :: _ -> Some href + | _ -> None + in let parse_tree = (* Parse a single XRD tree. *) + Xmlm.input_tree + ~el:(fun tag children + -> match tag with + | ((_, "Link"), attributes) -> link_websocket attributes + | ((_, "XRD"), _) -> List.find_map (fun x -> x) children + | _ -> None) + ~data:(fun x -> Some x) + in ignore (Xmlm.input i); (* DTD *) + match parse_tree i with + | Some uri -> uri + | None -> failwith (domain ^ "doesn't advertise a WebSocket endpoint via Web-host Metadata.") + +let ws_stream (url : string) = + (** [ws_stream url] returns a stream (and its push function) that talk with the websocket located at [url]. + Pushing [None] closes the websocket. - If the websocket is closed server-side, it's up to the caller's to close the push stream. *) + + If the websocket is closed server-side, it's still up to the caller to close the stream. *) let open Lwt_stream in let handle ws incoming () = let+ _ = iter (fun msg -> ws##send (jss msg)) incoming |