feat(stream): parse_features returns a feature list

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