diff options
| -rw-r--r-- | lib/stream.ml | 34 |
1 files changed, 12 insertions, 22 deletions
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 [<stream:features>] 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 - <starttls/> 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 + <starttls/> 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 |