open Lwt.Syntax
open Xml

(** This type is used to configure the STARTTLS handshake during the stream negotiation.

    When the XMPP server advertises optional STARTTLS support, whether the connection
    will be upgraded to STARTTLS depends on [prefer_starttls]. *)
type config = {
    prefer_starttls : bool
  }

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