blob: 7391fd6102aacff603528b90f6c544f1c5e1e5d8 (
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
|
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
|
