feat(portal): add field in t for underlying socket

4 files changed, 10 insertions, 7 deletions

diff --git a/lib/sasl.ml b/lib/sasl.ml
index 02c9222..1837044 100644
--- a/lib/sasl.ml
+++ b/lib/sasl.ml
@@ -29,7 +29,7 @@ let parse_sasl_error = function
 
 type sasl_auth = (string option, sasl_error * (string * string) option) result
 
-let send_auth_stanza ({stream; push} : Portal.t) localpart pass mechanism =
+let send_auth_stanza ({stream; push; _} : Portal.t) localpart pass mechanism =
   let gen_auth = function
     | PLAIN -> Base64.encode_exn ("\x00" ^ localpart ^ "\x00" ^ pass)
     | Unknown s -> failwith "Unsupported authentication mechanism " ^ s
diff --git a/portal/portal.mli b/portal/portal.mli
index 1fe90ef..808e1fa 100644
--- a/portal/portal.mli
+++ b/portal/portal.mli
@@ -7,6 +7,7 @@ type socket
 type t = {
     stream : (signal, async) stream;
     push : (signal, sync) stream option -> unit;
+    _socket : socket;
   }
 
 (** This is the XML namespace of the underlying element stream.
diff --git a/portal/tcp/portal.ml b/portal/tcp/portal.ml
index 931cf93..8d0c8fc 100644
--- a/portal/tcp/portal.ml
+++ b/portal/tcp/portal.ml
@@ -7,13 +7,14 @@ type socket = file_descr
 type t = {
     stream : (signal, async) stream;
     push : (signal, sync) stream option -> unit;
+    _socket : socket;
   }
 
 let xmlns = "http://etherx.jabber.org/streams"
 
 exception MalformedStanza of Markup.location * Markup.Error.t
 
-let header ?from domain ({stream; push} : t) =
+let header ?from domain ({stream; push; _} : t) =
   let stanza =
     let attributes =
       [(("", "to"), domain); (("", "version"), "1.0");
@@ -102,4 +103,4 @@ let connect (domain : string) : t Lwt.t =
   in Lwt.async (fun () ->
          let* _ = lwt_stream xml_stream |> Markup_lwt.write_xml |> iter send
          in Lwt_unix.close tcp_socket);
-     {stream; push}
+     {stream; push; _socket=tcp_socket}
diff --git a/portal/ws/portal.ml b/portal/ws/portal.ml
index ee4b636..dfd12cf 100644
--- a/portal/ws/portal.ml
+++ b/portal/ws/portal.ml
@@ -10,6 +10,7 @@ type socket = WebSockets.webSocket Js.t
 type t = {
     stream : (signal, async) stream;
     push : (signal, sync) stream option -> unit;
+    _socket : socket;
   }
 
 let xmlns = "urn:ietf:params:xml:ns:xmpp-framing"
@@ -21,7 +22,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 header ?from domain {stream; push} =
+let header ?from domain {stream; push; _} =
   let stanza =
     let attributes =
       let open Option in
@@ -111,7 +112,7 @@ let ws_stream (url : string) =
      in ws##.onclose := Dom.handler (fun _ -> message None; Js._true);
         ws##.onmessage := Dom.handler (fun x -> Some (sjs x##.data) |> message; Js._false);
         ws##.onopen := Dom.handler (fun _ -> signal is_open (); Js._false);
-        let+ () = wait is_open in stream, push
+        let+ () = wait is_open in stream, push, ws
 
 (** [connect domain] is an Lwt stream (and its push function) communicating with the
     XMPP server running at [domain] via the Websocket subprotocol.
@@ -128,7 +129,7 @@ let ws_stream (url : string) =
     function user                                     websocket
         \ <--- stream <--- markup_lwt <--- ws_stream <--- / *)
 let connect domain =
-  let+ ws_stream, ws_push = ws_endpoint domain >>= ws_stream in
+  let+ ws_stream, ws_push, ws = ws_endpoint domain >>= ws_stream in
   let open Markup_lwt in
   (* When sending a malformed stanza (one that Markup.ml doesn't like), a
      MalformedStanza exception is raised. *)
@@ -153,4 +154,4 @@ let connect domain =
                |> map (fun x -> write_xml x |> to_string)
                |> to_lwt_stream
                |> Lwt_stream.iter (fun s -> ws_push (Some s)));
-  {stream; push}
+  {stream; push; _socket=ws}