blob: bdf798796db1b9b748ca77d5c2e0457543eaacb5 (
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
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
open Lwt.Syntax
open Lwt.Infix
exception ClosedStream
exception InsufficientEncryption
type feature =
| STARTTLS
| Mechanisms of Sasl.mechanism list
| Other of Xml.element
type config = {
starttls : Starttls.config;
sasl : Sasl.config;
other : (Markup.signal, Markup.sync) Markup.stream list;
}
(** [features] is a tuple of features list, mandatory and optional. *)
type features = (feature list * feature list)
(** [parse_features stanza] is a tuple of the list of all mandatory features and all
optional features described in the <features> [stanza]. *)
let parse_features (stanza : Xml.element) : features =
let open Xml in
let open Either in
let children =
if not (List.for_all is_left stanza.children)
then raise (InvalidStanza (element_to_string stanza))
else List.filter_map find_left stanza.children
in
let parse_single_mechanism = function
| Left {local_name = "mechanism"; children = [Right mechanism]; _} ->
Sasl.parse_mechanism mechanism
| _ -> raise (InvalidStanza (element_to_string stanza))
in
let parse_feature (stanza : Xml.element) : (feature, feature) Either.t =
let parse_mechanisms mech_stanza = List.map parse_single_mechanism mech_stanza
in match stanza with
| {local_name="mechanisms"; _} -> Left (Mechanisms (parse_mechanisms stanza.children))
| {local_name="starttls"; children=[Left {local_name="required"; _}]; _} -> Left STARTTLS
| {local_name="starttls"; children=[]; _} -> Right STARTTLS
| _ -> Right (Other stanza)
in let features = List.partition_map parse_feature children
(* The XMPP spec mandates that sending a features element that contains only a
<starttls/> means the STARTTLS negotiation is required. *)
in match features with
| [], [STARTTLS] -> [STARTTLS], []
| _ -> features
(** [start domain portal] is a promise to features that starts a stream negotiation with
the XMPP server [portal]. *)
let start (domain : string) (portal : Portal.t) : features Lwt.t =
let* _id = Portal.header domain portal
in Wire.get portal.stream >|= parse_features
(** [negotiate mandatory feature portal] negotiates the feature [feature] with the XMPP
server at [portal].
Some features can be sent as [mandatory] or not. *)
let negotiate mandatory feature portal {starttls; sasl; _} : unit Lwt.t =
(* authenticate using SASL with the XMPP server. *)
let authenticate mechanisms =
let open Sasl in
let open Portal in
let allow_auth () =
_encrypted portal._socket || Option.is_some (Sys.getenv_opt "FLESH_ALLOW_STRIPTLS")
and parse_auth_error = function
| NotAuthorized, Some (_, text) -> "Not authorized: " ^ text
| MalformedRequest, Some (_, text) -> "Malformed request: " ^ text
| _ -> "Unknown error!"
in
if allow_auth () then
let* auth_result = authenticate portal sasl mechanisms
in match auth_result with
| Error err -> Lwt.fail_with (parse_auth_error err)
| Ok _ -> print_endline "Success!"; Lwt.return_unit
else Lwt.fail InsufficientEncryption
in match feature with
| STARTTLS -> if mandatory || starttls.prefer_starttls
then Starttls.upgrade portal
else Lwt.return_unit
| Mechanisms mechs -> authenticate mechs
| _ -> Lwt.return_unit
|
