diff options
| -rw-r--r-- | lib/stream.ml | 2 | ||||
| -rw-r--r-- | portal/portal.mli | 9 | ||||
| -rw-r--r-- | portal/tcp/portal.ml | 2 | ||||
| -rw-r--r-- | portal/ws/portal.ml | 19 |
4 files changed, 24 insertions, 8 deletions
diff --git a/lib/stream.ml b/lib/stream.ml index ea64f0a..c817571 100644 --- a/lib/stream.ml +++ b/lib/stream.ml @@ -45,7 +45,7 @@ let start domain : Portal.t Lwt.t = in let push = function | None -> Portal.close (stream, _push); | anything -> _push anything - in let+ _id = Portal.negotiate domain (stream, _push) + in let+ _id = Portal.header domain (stream, _push) in stream, push (** [parse_features el] is a [stream_features] record with all the features of the diff --git a/portal/portal.mli b/portal/portal.mli index f063cd7..dea8b38 100644 --- a/portal/portal.mli +++ b/portal/portal.mli @@ -12,11 +12,12 @@ type t = (signal, async) stream * ((signal, sync) stream option -> unit) Still, bad implementations exist -- Use with care. *) val xmlns : string -(** [negotiate domain portal] negotiates an open stream between the provided [portal] - and the XMPP server. It returns the server-assigned [id] of the stream. +(** [header domain portal] sends an initial stream header to the provided [portal] and + the XMPP server. It returns the server-assigned [id] of the stream included in the + response stream header. - If [from] is specified, the opening stanza is signed with the JID specified. *) -val negotiate : ?from:string -> string -> t -> string Lwt.t + When [from] is specified, a from attribute is included. *) +val header : ?from:string -> string -> t -> string Lwt.t (** [close portal] closes the stream between [portal] and the XMPP server. *) val close : t -> unit diff --git a/portal/tcp/portal.ml b/portal/tcp/portal.ml index 854f76c..0532c39 100644 --- a/portal/tcp/portal.ml +++ b/portal/tcp/portal.ml @@ -8,7 +8,7 @@ let xmlns = "jabber:client" exception MalformedStanza of Markup.location * Markup.Error.t -let negotiate ?from domain ((stream, push) : t) = +let header ?from domain ((stream, push) : t) = let stanza = let attributes = [(("", "to"), domain); (("", "version"), "1.0"); diff --git a/portal/ws/portal.ml b/portal/ws/portal.ml index 620d70e..b2a3119 100644 --- a/portal/ws/portal.ml +++ b/portal/ws/portal.ml @@ -16,7 +16,7 @@ let well_known_of (domain : string) = "https://" ^ domain ^ "/.well-known/host-m (** [open_stanza domain] is an <open /> stanza for [domain]. If [from] is specified, the <open /> stanza has the from parameter. *) -let stanza_open ?from domain : (signal, sync) stream = +let header ?from domain (stream, push) = let stanza = let attributes = let open Option in @@ -29,7 +29,22 @@ let stanza_open ?from domain : (signal, sync) stream = ((xmlns, "open"), attributes); `End_element] - in stanza |> of_list + and error = Lwt.fail_with "TODO" + in push (Some (of_list stanza)); + let* stanza_open = Markup_lwt.next stream in + let some id = + let* close = Markup_lwt.next stream in + match close with + | Some `End_element -> Lwt.return id + | _ -> error + in + match stanza_open with + | Some `Start_element ((ns, "open"), attributes) when ns = xmlns -> + List.find_map + (fun ((_, name), value) -> if name = "id" then Some value else None) + attributes + |> Option.fold ~none:error ~some + | _ -> error let stanza_close = {|<close xmlns="|} ^ xmlns ^ {|" />|} |> string |> parse_xml |> signals |