blob: 714defe32fbf1fd0e7c326d19a97dbcd8fc74ec6 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
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
|
