open Lwt.Syntax
open Xml

exception TLSError

(** [STARTTLSFailure] is thrown if the server doesn't allow the STARTTLS negotiation to
    proceed, either by sending back a [<failure/>] or by unspecified behavior. *)
exception STARTTLSFailure

(** [stanza] is a correct [<starttls/>] stanza as a stream of signals. *)
let stanza =
  Markup.of_list
    [`Start_element
       ((Xmlns.tls, "starttls"),
        [(("http://www.w3.org/2000/xmlns/", "xmlns"), Xmlns.tls)]);
     `End_element]

(** [parse_reply response] parses [response] as a STARTTLS handshake reply. *)
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

(** [upgrade portal] upgrades the Portal to STARTTLS. *)
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