-
Notifications
You must be signed in to change notification settings - Fork 20
/
xconfig.ml
175 lines (164 loc) · 9.24 KB
/
xconfig.ml
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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
open Sexplib
open Sexplib.Conv
type auth = [
| `Fingerprint of string
| `Trust_anchor of string
] [@@deriving sexp]
type t = {
version : int ;
jid : Xjid.full_jid ;
priority : int option ;
hostname : string option ;
port : int option ;
password : string option ;
authenticator : auth ;
otr_config : Otr.State.config ;
dsa : Mirage_crypto_pk.Dsa.priv ;
certificate_hostname : string option ;
notification_callback : string option ;
log_top : bool ;
muc_max_stanzas : int option ;
}
let current_version = 3
let dsa_priv_of_sexp s =
let z_of_sexp s = Z.of_string (string_of_sexp s) in
match list_of_sexp (pair_of_sexp string_of_sexp z_of_sexp) s with
| [ "p", p; "q", q; "gg", gg; "x", x; "y", y ] ->
(match Mirage_crypto_pk.Dsa.priv ?fips:None ~p ~q ~gg ~x ~y () with
| Ok p -> p
| Error (`Msg m) -> invalid_arg ("bad private " ^ m))
| _ -> raise (Of_sexp_error (Failure "expected p, q, gg, x, and y'", s))
let dsa_of_cfg_sexp t =
match t with
| Sexp.List l ->
(List.fold_left (fun (dsa, cfg) -> function
| Sexp.List [ Sexp.Atom "otr_config" ; Sexp.List data ] ->
List.fold_left (fun (dsa, cfg) -> function
| Sexp.List [ Sexp.Atom "policies" ; _ ] as p -> (dsa, p :: cfg)
| Sexp.List [ Sexp.Atom "versions" ; _ ] as v -> (dsa, v :: cfg)
| Sexp.List [ Sexp.Atom "dsa" ; d ] -> (Some (dsa_priv_of_sexp d), cfg)
| _ -> raise (Invalid_argument "broken sexp while trying to find dsa"))
(dsa, cfg) data
| _ -> (dsa, cfg))
(None, []) l)
| _ -> raise (Invalid_argument "couldn't parse sexp (dsa)")
let t_of_sexp dsa t =
let dsa, otr_cfg = match dsa, dsa_of_cfg_sexp t with
| None, (Some dsa, cfg) -> dsa, cfg
| Some x, (_, cfg) -> x, cfg
| _ -> raise (Invalid_argument "broken config")
in
let otr_config = Otr.State.config_of_sexp (Sexp.List otr_cfg) in
match t with
| Sexp.List l ->
(match
List.fold_left (fun (ver, jid, prio, host, port, pass, auth, cert, notification, log_top, muc_max_stanzas) -> function
| Sexp.List [ Sexp.Atom "version" ; v ] ->
assert (ver = None) ;
let version = int_of_sexp v in
(Some version, jid, prio, host, port, pass, auth, cert, notification, log_top, muc_max_stanzas)
| Sexp.List [ Sexp.Atom "jid" ; Sexp.Atom v ] ->
assert (jid = None) ;
let jid =
match Xjid.string_to_full_jid v with
| None -> raise (Invalid_argument "parse error in jid")
| Some x -> x
in
(ver, Some jid, prio, host, port, pass, auth, cert, notification, log_top, muc_max_stanzas)
| Sexp.List [ Sexp.Atom "priority" ; p ] ->
assert (prio = None) ;
let prio = option_of_sexp int_of_sexp p
in
(ver, jid, Some prio, host, port, pass, auth, cert, notification, log_top, muc_max_stanzas)
| Sexp.List [ Sexp.Atom "hostname" ; h ] ->
assert (host = None) ;
let host = option_of_sexp string_of_sexp h in
(ver, jid, prio, Some host, port, pass, auth, cert, notification, log_top, muc_max_stanzas)
| Sexp.List [ Sexp.Atom "port" ; p ] ->
assert (port = None) ;
let port =
match ver with
| Some x when x < 3 ->
let p = int_of_sexp p in
if p = 5222 then None else Some p
| _ -> option_of_sexp int_of_sexp p
in
(ver, jid, prio, host, Some port, pass, auth, cert, notification, log_top, muc_max_stanzas)
| Sexp.List [ Sexp.Atom "password" ; password ] ->
assert (pass = None) ;
let pass = match ver with
| Some x when x < 3 -> string_of_sexp password
| _ -> raise (Invalid_argument "password stored in V3+ file")
in
(ver, jid, prio, host, port, Some pass, auth, cert, notification, log_top, muc_max_stanzas)
| Sexp.List [ Sexp.Atom "trust_anchor" ; trust_anchor ] ->
assert (auth = None) ;
(match ver with
| Some 0 ->
let auth = Some (`Trust_anchor (string_of_sexp trust_anchor)) in
(ver, jid, prio, host, port, pass, auth, cert, notification, log_top, muc_max_stanzas)
| Some 1 -> ( match option_of_sexp string_of_sexp trust_anchor with
| None -> (ver, jid, prio, host, port, pass, auth, cert, notification, log_top, muc_max_stanzas)
| Some x -> (ver, jid, prio, host, port, pass, Some (`Trust_anchor x), cert, notification, log_top, muc_max_stanzas) )
| _ -> raise (Invalid_argument "unexpected element: trust_anchor") )
| Sexp.List [ Sexp.Atom "tls_fingerprint" ; tls_fp ] ->
assert (auth = None) ;
( match ver with
| Some 1 ->
( match option_of_sexp string_of_sexp tls_fp with
| None -> (ver, jid, prio, host, port, pass, auth, cert, notification, log_top, muc_max_stanzas)
| Some x -> (ver, jid, prio, host, port, pass, Some (`Fingerprint x), cert, notification, log_top, muc_max_stanzas) )
| _ -> raise (Invalid_argument "unexpected element: tls_fingerprint") )
| Sexp.List [ Sexp.Atom "authenticator" ; authenticator ] ->
assert (auth = None) ;
(ver, jid, prio, host, port, pass, Some (auth_of_sexp authenticator), cert, notification, log_top, muc_max_stanzas)
| Sexp.List [ Sexp.Atom "otr_config" ; _ ] ->
(ver, jid, prio, host, port, pass, auth, cert, notification, log_top, muc_max_stanzas)
| Sexp.List [ Sexp.Atom "certificate_hostname" ; c ] ->
assert (cert = None) ;
let cert = option_of_sexp string_of_sexp c in
(ver, jid, prio, host, port, pass, auth, cert, notification, log_top, muc_max_stanzas)
| Sexp.List [ Sexp.Atom "notification_callback" ; c ] ->
assert (notification = None) ;
let notification = option_of_sexp string_of_sexp c in
(ver, jid, prio, host, port, pass, auth, cert, notification, log_top, muc_max_stanzas)
| Sexp.List [ Sexp.Atom "log_top" ; c ] ->
let log_top = bool_of_sexp c in
(ver, jid, prio, host, port, pass, auth, cert, notification, log_top, muc_max_stanzas)
| Sexp.List [ Sexp.Atom "muc_max_stanzas" ; p ] ->
assert (muc_max_stanzas = None) ;
let mms = option_of_sexp int_of_sexp p in
(ver, jid, prio, host, port, pass, auth, cert, notification, log_top, mms)
| _ -> (ver, jid, prio, host, port, pass, auth, cert, notification, log_top, muc_max_stanzas))
(None, None, None, None, None, None, None, None, None, false, None) l
with
| Some version, Some jid, Some priority, Some hostname, Some port, password, Some authenticator, certificate_hostname, notification_callback, log_top, muc_max_stanzas ->
{ version ; jid ; priority ; hostname ; port ; password ; authenticator ; otr_config ; dsa ; certificate_hostname ; notification_callback ; log_top ; muc_max_stanzas }
| Some version, Some jid, None, Some hostname, Some port, password, Some authenticator, certificate_hostname, notification_callback, log_top, muc_max_stanzas ->
{ version ; jid ; priority = None ; hostname ; port ; password ; authenticator ; otr_config ; dsa ; certificate_hostname ; notification_callback ; log_top ; muc_max_stanzas }
| Some version, Some jid, Some priority, None, Some port, password, Some authenticator, certificate_hostname, notification_callback, log_top, muc_max_stanzas ->
{ version ; jid ; priority ; hostname = None ; port ; password ; authenticator ; otr_config ; dsa ; certificate_hostname ; notification_callback ; log_top ; muc_max_stanzas }
| Some version, Some jid, None, None, Some port, password, Some authenticator, certificate_hostname, notification_callback, log_top, muc_max_stanzas ->
{ version ; jid ; priority = None ; hostname = None ; port ; password ; authenticator ; otr_config ; dsa ; certificate_hostname ; notification_callback ; log_top ; muc_max_stanzas }
| _ -> raise (Invalid_argument "broken config") )
| _ -> raise (Invalid_argument "broken config")
let record kvs =
Sexp.List List.(map (fun (k, v) -> (Sexp.List [Sexp.Atom k; v])) kvs)
let sexp_of_t t =
record [
"version" , sexp_of_int t.version ;
"jid" , sexp_of_string (Xjid.full_jid_to_string t.jid) ;
"hostname" , sexp_of_option sexp_of_string t.hostname ;
"port" , sexp_of_option sexp_of_int t.port ;
"priority" , sexp_of_option sexp_of_int t.priority ;
"authenticator" , sexp_of_auth t.authenticator ;
"otr_config" , Otr.State.sexp_of_config t.otr_config ;
"certificate_hostname" , sexp_of_option sexp_of_string t.certificate_hostname ;
"notification_callback", sexp_of_option sexp_of_string t.notification_callback ;
"log_top" , sexp_of_bool t.log_top ;
"muc_max_stanzas" , sexp_of_option sexp_of_int t.muc_max_stanzas ;
]
let load_config dsa bytes =
t_of_sexp dsa (Sexp.of_string bytes)
let store_config t =
Bytes.of_string (Sexp.to_string_hum (sexp_of_t t))