fix(stream): allow <starttls/> required special case

1 files changed, 12 insertions, 4 deletions

diff --git a/lib/stream.ml b/lib/stream.ml
index b997a25..d544f14 100644
--- a/lib/stream.ml
+++ b/lib/stream.ml
@@ -30,10 +30,18 @@ let parse_features (el : Xml.element) : features =
        | "mechanisms" -> {acc with mechanisms=parse_mechanisms feature.children}
        | "starttls" ->  {acc with starttls=parse_starttls feature.children}
        | _ -> {acc with unknown = feature :: acc.unknown}
-  in List.fold_left
-       parse_feature
-       {mechanisms=[]; starttls=`None; unknown=[]}
-       (List.filter_map find_left el.children)
+  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)
 
 (** [negotiate domain portal auth] is a promise containing the features supported by the
     XMPP server [portal], after eventual STARTTLS negotiation and authentication using