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