aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorClombrong <cromblong@egregore.fun>2025-06-25 18:06:07 +0200
committerClombrong <cromblong@egregore.fun>2025-06-25 18:06:07 +0200
commit9b22f650dafeb8dc193dadd1a10182724382c6a7 (patch)
treed1d64e6b0fbef0c00273cd03f5c33efa90797ff9
parent5f52ab70862cfa8332ec5bd9d1dc3d3f6af37d16 (diff)
chore: move comments to correct location
-rw-r--r--lib/stream.ml19
-rw-r--r--lib/xml.ml14
-rw-r--r--portal/tcp/portal_tcp.ml8
-rw-r--r--portal/ws/portal.ml61
4 files changed, 50 insertions, 52 deletions
diff --git a/lib/stream.ml b/lib/stream.ml
index 4781161..21c134d 100644
--- a/lib/stream.ml
+++ b/lib/stream.ml
@@ -18,10 +18,9 @@ type stream_features = {
unknown_features : Xml.element list;
}
+(** [next stream] is a promise containing a full stanza of the fragments of
+ [stream]. *)
let next (stream : (signal, async) stream) : (signal, sync) stream Lwt.t =
- (** [next stream] is a promise containing a full stanza of the fragments of
- [stream]. *)
-
let traverse_stanza depth fragment =
let depth = match fragment with
| `Start_element _ -> depth + 1
@@ -30,18 +29,18 @@ let next (stream : (signal, async) stream) : (signal, sync) stream Lwt.t =
in ([fragment], if depth = 0 then None else Some depth)
in transform traverse_stanza 0 stream |> Markup_lwt.load
+(** [get stream] is a promise containing a single Xml element of [stream]. *)
let get (stream : (signal, async) stream) : Xml.element Lwt.t =
- (** [get stream] is a promise containing a single Xml element of [stream]. *)
let* signal = next stream
in match Xml.tree signal with
| Some xml -> Lwt.return xml
| None -> Lwt.fail (InvalidStanza (signal |> write_xml |> to_string))
-let start domain : Portal.t Lwt.t =
- (** [start domain] is a promise containing a Portal (stream * push) connected to the
- XMPP server [domain].
+(** [start domain] is a promise containing a Portal (stream * push) connected to the
+ XMPP server [domain].
- Currently, it doesn't handle anything except the initial [<open/>] stanza. *)
+ Currently, it doesn't handle anything except the initial [<open/>] stanza. *)
+let start domain : Portal.t Lwt.t =
let* stream, _push = Portal.connect domain
in let push = function
| None -> _push (Some Portal.stanza_close);
@@ -52,9 +51,9 @@ let start domain : Portal.t Lwt.t =
let+ _ = get stream
in stream, push
+(** [parse_features el] is a [stream_features] record with all the features of the
+ [<stream:features>] stanza contained in [el]. *)
let parse_features (el : Xml.element) : stream_features =
- (** [parse_features el] is a [stream_features] record with all the features of the
- [<stream:features>] stanza contained in [el]. *)
let open Xml in
let open Either in
let parse_mechanism_stanza = function
diff --git a/lib/xml.ml b/lib/xml.ml
index dff9652..840aaf0 100644
--- a/lib/xml.ml
+++ b/lib/xml.ml
@@ -7,9 +7,9 @@ type element = {
children : (element, string) Either.t list;
}
+(** [tree s] is an [element option] representing the XML element inside of stream [s],
+ if [s] is a complete element from start to end. *)
let tree s : element option =
- (** [tree s] is an [element option] representing the XML element inside of stream [s],
- if [s] is a complete element from start to end. *)
let element (namespace, name) attributes children =
Either.Left {
namespace;
@@ -27,12 +27,12 @@ let tree s : element option =
let opt_el = tree ~text ~element s in
Option.bind opt_el (Either.fold ~left:Option.some ~right:(fun _ -> None))
-let element_to_string ?(indent = 2) (el : element) =
- (** [element_to_string element] is a string representation of the underlying XML in
- [element], for debugging purposes.
+(** [element_to_string element] is a string representation of the underlying XML in
+ [element], for debugging purposes.
- Note this isn't serialization: namely, XML namespaces are inferred and don't exist
- in the actual [element]. *)
+ Note this isn't serialization: namely, XML namespaces are inferred and don't exist
+ in the actual [element]. *)
+let element_to_string ?(indent = 2) (el : element) =
let rec element_to_string parent {local_name; attributes; children; namespace} =
let attributes =
(if parent == namespace then "" else " xmlns=\"" ^ namespace ^ "\"") ^
diff --git a/portal/tcp/portal_tcp.ml b/portal/tcp/portal_tcp.ml
index cfe35dd..3aa5e56 100644
--- a/portal/tcp/portal_tcp.ml
+++ b/portal/tcp/portal_tcp.ml
@@ -1,8 +1,8 @@
-let xmpp_port (_domain : string) : int = 5222
- (** [xmpp_port domain] is the port where [domain]'s XMPP server is hosted.
+(** [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
- future. *)
+ Currently, it falls back to 5222 (always), but should use SRV records in the near
+ future. *)
+let xmpp_port (_domain : string) : int = 5222
let connect (domain : string) =
xmpp_port domain |> string_of_int |> print_endline
diff --git a/portal/ws/portal.ml b/portal/ws/portal.ml
index 2916e66..916fd2f 100644
--- a/portal/ws/portal.ml
+++ b/portal/ws/portal.ml
@@ -13,11 +13,10 @@ let xmlns = "urn:ietf:params:xml:ns:xmpp-framing"
rules. *)
let well_known_of (domain : string) = "https://" ^ domain ^ "/.well-known/host-meta"
-let stanza_open ?from domain : (signal, sync) stream =
- (** [open_stanza domain] is an <open /> stanza for [domain].
+(** [open_stanza domain] is an <open /> stanza for [domain].
- If [from] is specified, the <open /> stanza has the from parameter.
- *)
+ If [from] is specified, the <open /> stanza has the from parameter. *)
+let stanza_open ?from domain : (signal, sync) stream =
let open Markup in
let stanza =
let attributes =
@@ -37,16 +36,16 @@ let stanza_close = {|<close xmlns="|} ^ xmlns ^ {|" />|} |> string |> parse_xml
exception MalformedStanza of Markup.location * Markup.Error.t
-let ws_endpoint (domain : string) : string Lwt.t =
- (** [ws_endpoint domain] is a promise containing the XMPP websocket endpoint
- associated with [domain], by using the domain's Web-host Metadata.
+(** [ws_endpoint domain] is a promise containing the XMPP websocket endpoint
+ associated with [domain], by using the domain's Web-host Metadata.
- This function uses XMLHttpRequest, so while it should work fine in the browser, in
- environments that don't provide this constructor (Node.js), there should be some
- sort of polyfill.
+ This function uses XMLHttpRequest, so while it should work fine in the browser, in
+ environments that don't provide this constructor (Node.js), there should be some
+ sort of polyfill.
- Lastly, if [domain] doesn't provide a well-formed Web-host Metadata file, the
- function throws an exception. *)
+ Lastly, if [domain] doesn't provide a well-formed Web-host Metadata file, the
+ function throws an exception. *)
+let ws_endpoint (domain : string) : string Lwt.t =
let open Markup in
(* This ugly function extracts the href element from a Link tag's attributes if it's a
websocket. *)
@@ -72,16 +71,16 @@ let ws_endpoint (domain : string) : string Lwt.t =
| Some x -> Lwt.return x
| None -> Lwt.fail_with (domain ^ ": no WebSocket endpoint in Web-host Metadata.")
-let ws_stream (url : string) =
- (** [ws_stream url] is a promise to a framed Lwt stream (and its push function)
- communicating with the websocket located at [url] using the XMPP protocol.
+(** [ws_stream url] is a promise to a framed Lwt stream (and its push function)
+ communicating with the websocket located at [url] using the XMPP protocol.
- Valid XMPP WebSocket subprotocol frames must be sent to the stream, because it
- directly exposes the websocket under.
+ Valid XMPP WebSocket subprotocol frames must be sent to the stream, because it
+ directly exposes the websocket under.
- Pushing [None] closes the websocket.
+ Pushing [None] closes the websocket.
- If the websocket is closed server-side, the stream closes. *)
+ If the websocket is closed server-side, the stream closes. *)
+let ws_stream (url : string) =
let open Lwt_stream in
let stream, message = create () in
let open Lwt_condition in
@@ -96,21 +95,21 @@ let ws_stream (url : string) =
ws##.onopen := Dom.handler (fun _ -> signal is_open (); Js._false);
let+ () = wait is_open in stream, push
-let connect domain =
- (** [connect domain] is an Lwt stream (and its push function) communicating with the
- XMPP server running at [domain] via the Websocket subprotocol.
+(** [connect domain] is an Lwt stream (and its push function) communicating with the
+ XMPP server running at [domain] via the Websocket subprotocol.
- This function is a complex wrapper around ws_stream, that accepts Markup.ml
- signals and sends framed XML stanzas to the underlying socket, with exactly one
- stanza per frame, according to RFC 7935.
+ This function is a complex wrapper around ws_stream, that accepts Markup.ml
+ signals and sends framed XML stanzas to the underlying socket, with exactly one
+ stanza per frame, according to RFC 7935.
- In essence, it (tries to) expose an identical interface to the original XMPP
- streamed protocol.
+ In essence, it (tries to) expose an identical interface to the original XMPP
+ streamed protocol.
- Here's an ASCII rendered flow of the data through the various streams.
- / -> push -> mu_stream -> to_frames -> ws_push -> \
- function user websocket
- \ <--- stream <--- markup_lwt <--- ws_stream <--- / *)
+ Here's an ASCII rendered flow of the data through the various streams.
+ / -> push -> mu_stream -> to_frames -> ws_push -> \
+ function user websocket
+ \ <--- stream <--- markup_lwt <--- ws_stream <--- / *)
+let connect domain =
let+ ws_stream, ws_push = ws_endpoint domain >>= ws_stream in
let open Markup_lwt in
(* When sending a malformed stanza (one that Markup.ml doesn't like), a