diff options
Diffstat (limited to 'lib')
-rw-r--r-- | lib/dune (renamed from lib/flesh/dune) | 0 | ||||
-rw-r--r-- | lib/flesh.ml (renamed from lib/flesh/flesh.ml) | 0 | ||||
-rw-r--r-- | lib/portal/dune | 6 | ||||
-rw-r--r-- | lib/portal/portal_ws.ml | 58 |
4 files changed, 0 insertions, 64 deletions
diff --git a/lib/flesh/dune b/lib/dune index d79e297..d79e297 100644 --- a/lib/flesh/dune +++ b/lib/dune diff --git a/lib/flesh/flesh.ml b/lib/flesh.ml index 969d285..969d285 100644 --- a/lib/flesh/flesh.ml +++ b/lib/flesh.ml diff --git a/lib/portal/dune b/lib/portal/dune deleted file mode 100644 index 8ce0232..0000000 --- a/lib/portal/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name portal_ws) - (modules portal_ws) - (public_name flesh_websockets) - (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 deleted file mode 100644 index c6dbf81..0000000 --- a/lib/portal/portal_ws.ml +++ /dev/null @@ -1,58 +0,0 @@ -open Lwt.Syntax -open Js_of_ocaml -let jss = Js.string -let sjs = Js.to_string - -(* 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 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 - 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 (jss url) - 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 |