diff options
Diffstat (limited to 'portal/tcp')
| -rw-r--r-- | portal/tcp/portal.ml | 80 |
1 files changed, 40 insertions, 40 deletions
diff --git a/portal/tcp/portal.ml b/portal/tcp/portal.ml index cec5212..5e75c76 100644 --- a/portal/tcp/portal.ml +++ b/portal/tcp/portal.ml @@ -14,46 +14,6 @@ let xmlns = "http://etherx.jabber.org/streams" exception MalformedStanza of Markup.Error.t -let header ?from domain ({stream; push; _} : t) = - let stanza = - let attributes = - [(("", "to"), domain); (("", "version"), "1.0"); - (("http://www.w3.org/XML/1998/namespace", "lang"), "en"); - (("http://www.w3.org/2000/xmlns/", "xmlns"), "jabber:client"); - (("http://www.w3.org/2000/xmlns/", "stream"), xmlns)] - in [`Xml {version="1.0"; encoding=None; standalone=None}; - `Start_element - (("http://etherx.jabber.org/streams", "stream"), - Option.fold - ~none:attributes - ~some:(fun jid -> (("", "from"), jid) :: attributes) - from); - (* Markup.ml is a streaming parser, but blocks on standalone [`Start_element] - because it doesn't know if this specific element should be self-closing or - not, so [write_xml] never spits out the start of the stream. Adding an empty - comment resolves the ambiguity. I'm not a fan of it. - - If you have Github, feel free to get the word out to aantron. *) - `Comment ""] - in push (Some (of_list stanza)); - let some_id ((_, name), value) = if name = "id" then Some value else None in - let* xml = Markup_lwt.next stream in - let* id = match xml with - | Some `Xml {version="1.0"; encoding=None; standalone=None} -> - let* stream_open = Markup_lwt.next stream in - begin match stream_open with - | Some `Start_element ((ns, "stream"), attributes) when ns = xmlns-> - List.find_map some_id attributes |> Lwt.return - | _ -> Lwt.return_none - end - | _ -> Lwt.return_none - in match id with - | Some id -> Lwt.return id - | None -> Lwt.fail_with "Invalid stream opening server-side." - -(** [close portal] is a closing tag to the [<stream>] document. *) -let close = [`End_element] |> Markup.of_list - (** [xmpp_port domain] is the port where [domain]'s XMPP server is hosted. Currently, it falls back to 5222 (always), but should use SRV records in the near @@ -201,3 +161,43 @@ let starttls (portal : t) : unit Lwt.t = in portal.stream <- stream; portal.push <- push; portal._socket <- sock + +let header ?from domain ({stream; push; _} : t) = + let stanza = + let attributes = + [(("", "to"), domain); (("", "version"), "1.0"); + (("http://www.w3.org/XML/1998/namespace", "lang"), "en"); + (("http://www.w3.org/2000/xmlns/", "xmlns"), "jabber:client"); + (("http://www.w3.org/2000/xmlns/", "stream"), xmlns)] + in [`Xml {version="1.0"; encoding=None; standalone=None}; + `Start_element + (("http://etherx.jabber.org/streams", "stream"), + Option.fold + ~none:attributes + ~some:(fun jid -> (("", "from"), jid) :: attributes) + from); + (* Markup.ml is a streaming parser, but blocks on standalone [`Start_element] + because it doesn't know if this specific element should be self-closing or + not, so [write_xml] never spits out the start of the stream. Adding an empty + comment resolves the ambiguity. I'm not a fan of it. + + If you have Github, feel free to get the word out to aantron. *) + `Comment ""] + in push (Some (of_list stanza)); + let some_id ((_, name), value) = if name = "id" then Some value else None in + let* xml = Markup_lwt.next stream in + let* id = match xml with + | Some `Xml {version="1.0"; encoding=None; standalone=None} -> + let* stream_open = Markup_lwt.next stream in + begin match stream_open with + | Some `Start_element ((ns, "stream"), attributes) when ns = xmlns-> + List.find_map some_id attributes |> Lwt.return + | _ -> Lwt.return_none + end + | _ -> Lwt.return_none + in match id with + | Some id -> Lwt.return id + | None -> Lwt.fail_with "Invalid stream opening server-side." + +(** [close portal] is a closing tag to the [<stream>] document. *) +let close = [`End_element] |> Markup.of_list |