refactor(portal_ws): stanza_open to header

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