refactor: port ws_endpoint to markup.ml

1 files changed, 22 insertions, 29 deletions

diff --git a/portal/lib/portal_ws.ml b/portal/lib/portal_ws.ml
index 9aeb1d4..1921891 100644
--- a/portal/lib/portal_ws.ml
+++ b/portal/lib/portal_ws.ml
@@ -14,35 +14,28 @@ let ws_endpoint (domain : string) =
       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 open Markup in
-     string host_meta.content
-     |> parse_xml
-     |> signals
-     |> write_xml
-     |> to_string
-
-(*
-  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 = function
-       | ((_, "rel"), "urn:xmpp:alt-connections:websocket") :: ((_, "href"), href) :: _
-       | ((_, "href"), href) :: ((_, "rel"), "urn:xmpp:alt-connections:websocket") :: _ -> Some href
-       | _ -> None
-     in let parse_xrd = (* 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)
-            (* The XRD tree doesn't hold any relevant XML data. *)
-            ~data:(fun _ -> None)
-        in ignore (Xmlm.input i); (* DTD stuff *)
-           match parse_xrd i with
-           | Some uri -> uri
-           | None -> failwith (domain ^ "doesn't advertise a WebSocket endpoint via Web-host Metadata.")
- *)
+  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] returns an Lwt stream (and its push function) communicating with the websocket located at [url]