From 3cc41d7b17f7398ba1fd8e4bd742d76d311ebba6 Mon Sep 17 00:00:00 2001 From: Clombrong Date: Sun, 29 Jun 2025 07:20:02 +0200 Subject: feat(stream): parse_features returns a feature list --- lib/stream.ml | 34 ++++++++++++---------------------- 1 file changed, 12 insertions(+), 22 deletions(-) (limited to 'lib/stream.ml') diff --git a/lib/stream.ml b/lib/stream.ml index 218cc37..bcd2073 100644 --- a/lib/stream.ml +++ b/lib/stream.ml @@ -10,7 +10,7 @@ type feature = (** [parse_features el] is a [features] record with all the features of the [] stanza contained in [el]. *) -let parse_features (el : Xml.element) : features = +let parse_features (el : Xml.element) : feature list = let open Xml in let open Either in @@ -26,32 +26,22 @@ let parse_features (el : Xml.element) : features = | _ -> raise (InvalidStanza (element_to_string el)) in - let parse_feature (acc : features) (feature : Xml.element) : features = - + let parse_feature (el : Xml.element) : feature = let parse_mechanisms ch = List.map parse_single_mechanism ch - and parse_starttls = function | [Left {local_name="required"; _}] -> `Required | [] -> `Optional | _ -> raise (InvalidStanza (element_to_string el)) - - in match feature.local_name with - | "mechanisms" -> {acc with mechanisms=parse_mechanisms feature.children} - | "starttls" -> {acc with starttls=parse_starttls feature.children} - | _ -> {acc with unknown = feature :: acc.unknown} - in - - (* The XMPP spec mandates that sending a features element that contains only a - means the STARTTLS negotiation is required. *) - match el.children with - | [Left {local_name="starttls"; - attributes=[]; - children=[]; - namespace; _}] when namespace = Xmlns.tls -> - {mechanisms=[]; starttls=`Required; unknown=[]} - | _ -> List.fold_left parse_feature - {mechanisms=[]; starttls=`None; unknown=[]} - (List.filter_map find_left el.children) + in match el.local_name with + | "mechanisms" -> Mechanisms (parse_mechanisms el.children) + | "starttls" -> STARTTLS (parse_starttls el.children) + | _ -> Other el + in let features = List.map parse_feature children + (* The XMPP spec mandates that sending a features element that contains only a + means the STARTTLS negotiation is required. *) + in match features with + | [STARTTLS _] -> [STARTTLS `Required] + | _ -> features (** [negotiate domain portal auth] is a promise containing the features supported by the XMPP server [portal], after eventual STARTTLS negotiation and authentication using -- cgit v1.2.3