diff options
| -rw-r--r-- | portal/portal.mli | 14 | ||||
| -rw-r--r-- | portal/tcp/portal.ml | 80 |
2 files changed, 47 insertions, 47 deletions
diff --git a/portal/portal.mli b/portal/portal.mli index fab9197..8790b77 100644 --- a/portal/portal.mli +++ b/portal/portal.mli @@ -22,6 +22,13 @@ type t = { since the Portal interface is supposed to be agnostic. *) val xmlns : string +(** [connect domain] returns a Portal connected to the XMPP server [domain]. *) +val connect : string -> t Lwt.t + +(** [starttls portal] mutates [portal] into a TLS-encrypted stream with the same + state. *) +val starttls : t -> unit Lwt.t + (** [header domain portal] sends an initial stream header to the XMPP server [portal] addressed to [domain]. It returns the server-assigned [id] of the stream included in the response stream header. @@ -33,10 +40,3 @@ val header : ?from:string -> string -> t -> string Lwt.t that the connection is closed. Namely, it does {b not} interact with the Portal in any way: It's the caller's job to provide it to the stream. *) val close : (signal, sync) stream - -(** [connect domain] returns a Portal connected to the XMPP server [domain]. *) -val connect : string -> t Lwt.t - -(** [starttls portal] mutates [portal] into a TLS-encrypted stream with the same - state. *) -val starttls : t -> unit Lwt.t 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 |