diff options
| -rw-r--r-- | lib/sasl.ml | 4 | ||||
| -rw-r--r-- | lib/stream.ml | 21 | ||||
| -rw-r--r-- | lib/xml.ml | 19 |
3 files changed, 21 insertions, 23 deletions
diff --git a/lib/sasl.ml b/lib/sasl.ml index 4404f74..ff6436a 100644 --- a/lib/sasl.ml +++ b/lib/sasl.ml @@ -53,7 +53,7 @@ let send_auth_stanza (stream, push) localpart pass mechanism = `Text [gen_auth mechanism]; `End_element] in Some (Markup.of_list stanza_list) |> push; - try get stream >|= parse_sasl_response + try Xml.get stream >|= parse_sasl_response with exn -> Lwt.fail exn let authenticate (portal : Portal.t) ({jid; password; preferred_mechanisms} : auth_config) = @@ -63,7 +63,7 @@ let authenticate (portal : Portal.t) ({jid; password; preferred_mechanisms} : au | [localpart; _domain] -> localpart | _ -> failwith "Invalid JID" in - let* {sasl_mechanisms; _} = Stream.get (fst portal) >|= Stream.parse_features + let* {sasl_mechanisms; _} = Xml.get (fst portal) >|= Stream.parse_features in let preferred, not_preferred = List.partition (fun f -> List.exists ((=) f) preferred_mechanisms) sasl_mechanisms in diff --git a/lib/stream.ml b/lib/stream.ml index cc15c4b..83587cd 100644 --- a/lib/stream.ml +++ b/lib/stream.ml @@ -1,6 +1,3 @@ -open Lwt.Syntax -open Markup - exception ClosedStream type auth_mechanism = @@ -17,24 +14,6 @@ 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 = - let traverse_stanza depth fragment = - let depth = match fragment with - | `Start_element _ -> depth + 1 - | `End_element -> depth - 1 - | _ -> depth - 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 = - let* signal = next stream - in match Xml.tree signal with - | Some xml -> Lwt.return xml - | None -> Lwt.fail (Xml.InvalidStanza (signal |> write_xml |> to_string)) - (** [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 = @@ -1,3 +1,4 @@ +open Lwt.Syntax open Markup exception InvalidStanza of string @@ -56,3 +57,21 @@ let element_to_string ?(indent = 2) (el : element) = |> tab) ^ "\n</" ^ local_name ^ ">" in element_to_string "" el |> String.trim + +(** [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 = + let traverse_stanza depth fragment = + let depth = match fragment with + | `Start_element _ -> depth + 1 + | `End_element -> depth - 1 + | _ -> depth + 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) : element Lwt.t = + let* signal = next stream + in match tree signal with + | Some xml -> Lwt.return xml + | None -> Lwt.fail (InvalidStanza (signal |> write_xml |> to_string)) |