feat(starttls): add upgrade function

1 files changed, 28 insertions, 0 deletions

diff --git a/lib/starttls.ml b/lib/starttls.ml
index e69de29..7391fd6 100644
--- a/lib/starttls.ml
+++ b/lib/starttls.ml
@@ -0,0 +1,28 @@
+open Lwt.Syntax
+open Xml
+
+exception TLSError
+exception STARTTLSFailure
+
+let stanza =
+  Markup.of_list
+    [`Start_element
+       ((Xmlns.tls, "starttls"),
+        [(("http://www.w3.org/2000/xmlns/", "xmlns"), Xmlns.tls)]);
+     `End_element]
+
+let parse_reply response =
+  match response with
+  | {namespace=ns; local_name="proceed";
+     attributes=[]; children=[]} when ns = Xmlns.tls -> `Proceed
+  | {namespace=ns; local_name="failure";
+     attributes=[]; children=[]} when ns = Xmlns.tls -> `Failure
+  | _ -> `Error
+
+let upgrade (portal : Portal.t) : unit Lwt.t =
+  portal.push (Some stanza);
+  let* response = Wire.get portal.stream
+  in match parse_reply response with
+     | `Failure | `Error -> Lwt.fail STARTTLSFailure
+     | `Proceed -> Portal.starttls portal
+