diff options
| -rw-r--r-- | dune-project | 2 | ||||
| -rw-r--r-- | flesh_websockets.opam | 2 | ||||
| -rw-r--r-- | lib/portal/dune | 2 | ||||
| -rw-r--r-- | lib/portal/portal_ws.ml | 42 | ||||
| -rw-r--r-- | test/js/websockets_hello.ml | 8 |
5 files changed, 47 insertions, 9 deletions
diff --git a/dune-project b/dune-project index a46653c..08f71c6 100644 --- a/dune-project +++ b/dune-project @@ -38,7 +38,9 @@ ocaml dune js_of_ocaml + js_of_ocaml-lwt js_of_ocaml-ppx + xmlm (flesh (and (= :version) :with-test))) diff --git a/flesh_websockets.opam b/flesh_websockets.opam index 553b2b3..4b8cd05 100644 --- a/flesh_websockets.opam +++ b/flesh_websockets.opam @@ -12,7 +12,9 @@ depends: [ "ocaml" "dune" {>= "3.11"} "js_of_ocaml" + "js_of_ocaml-lwt" "js_of_ocaml-ppx" + "xmlm" "flesh" {= version & with-test} "odoc" {with-doc} ] 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 diff --git a/test/js/websockets_hello.ml b/test/js/websockets_hello.ml index 41487b7..6b74d96 100644 --- a/test/js/websockets_hello.ml +++ b/test/js/websockets_hello.ml @@ -2,19 +2,19 @@ open Lwt.Syntax let () = (* Echo is a websocket that... echoes you stuff. *) - let stream, push = Portal_ws.lwt_ws "wss://echo.websocket.org" in + let stream, push = Portal_ws.ws_stream "wss://echo.websocket.org" in push (Some "great text"); push (Some "other text"); push (Some "yet another text"); push (Some "BYE"); Lwt.async @@ fun () -> - let+ s = Lwt_stream.iter + let* server = Portal_ws.ws_endpoint "egregore.fun" + in let+ _ = Lwt_stream.iter (fun greetings -> match greetings with (* When the websocket sends "BYE", we close. *) | "BYE" -> print_endline "CLOSING BYE"; push None | hello -> print_endline ("> " ^ hello)) stream - in s - + in print_endline server |