feat(stream): handle STARTTLS negotiation

1 files changed, 12 insertions, 4 deletions

diff --git a/lib/stream.ml b/lib/stream.ml
index ee33575..2b98192 100644
--- a/lib/stream.ml
+++ b/lib/stream.ml
@@ -43,10 +43,18 @@ let parse_features (el : Xml.element) : features =
 
     Basically, it conforms to
     {{: https://datatracker.ietf.org/doc/html/rfc6120#section-4.3 }}. *)
-let negotiate (domain : string) (portal : Portal.t) : features Lwt.t =
-  let* _id = Portal.header domain portal
-  in let+ features = Wire.get portal.stream >|= parse_features
-     in features
+let negotiate ?(prefer_starttls = true) (domain : string) (portal : Portal.t) : features Lwt.t =
+  (* Restart a stream: Send the usual business, ask for features. *)
+  let start_stream () : features Lwt.t =
+    let* _id = Portal.header domain portal
+    in Wire.get portal.stream >|= parse_features
+  in
+  let starttls features =
+    match features.starttls, prefer_starttls with
+    | `Optional, false | `None, _ -> Lwt.return features
+    | `Optional, true  | `Required, _->
+       Starttls.upgrade portal >>= start_stream
+  in start_stream () >>= starttls
 
 (** [initiate domain] initiates a stream with the XMPP server [domain].