Re-enable querying user firewall rules
[hcoop/domtool2.git] / src / msg.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006, Adam Chlipala
3 *
4 * This program is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU General Public License
6 * as published by the Free Software Foundation; either version 2
7 * of the License, or (at your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
13 *
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
17 *)
18
19 (* Network messages *)
20
21 structure Msg :> MSG = struct
22
23 open OpenSSL MsgTypes Slave
24
25 val a2i = fn Add => 0
26 | Delete true => 1
27 | Modify => 2
28 | Delete false => 3
29
30 val i2a = fn 0 => Add
31 | 1 => Delete true
32 | 2 => Modify
33 | 3 => Delete false
34 | _ => raise OpenSSL.OpenSSL "Bad action number to deserialize"
35
36 fun sendAcl (bio, {user, class, value}) =
37 (OpenSSL.writeString (bio, user);
38 OpenSSL.writeString (bio, class);
39 OpenSSL.writeString (bio, value))
40
41 fun recvAcl bio =
42 case (OpenSSL.readString bio, OpenSSL.readString bio, OpenSSL.readString bio) of
43 (SOME user, SOME class, SOME value) => SOME {user = user, class = class, value = value}
44 | _ => NONE
45
46 fun sendList f (bio, ls) =
47 (app (fn x =>
48 (OpenSSL.writeInt (bio, 1);
49 f (bio, x))) ls;
50 OpenSSL.writeInt (bio, 0))
51
52 fun recvList f bio =
53 let
54 fun loop ls =
55 case OpenSSL.readInt bio of
56 SOME 0 => SOME (rev ls)
57 | SOME 1 =>
58 (case f bio of
59 SOME x => loop (x :: ls)
60 | NONE => NONE)
61 | _ => NONE
62 in
63 loop []
64 end
65
66 fun sendOption f (bio, opt) =
67 case opt of
68 NONE => OpenSSL.writeInt (bio, 0)
69 | SOME x => (OpenSSL.writeInt (bio, 1);
70 f (bio, x))
71
72 fun recvOption f bio =
73 case OpenSSL.readInt bio of
74 SOME 0 => SOME NONE
75 | SOME 1 =>
76 (case f bio of
77 SOME x => SOME (SOME x)
78 | NONE => NONE)
79 | _ => NONE
80
81 fun sendBool (bio, b) =
82 if b then
83 OpenSSL.writeInt (bio, 1)
84 else
85 OpenSSL.writeInt (bio, 0)
86
87 fun recvBool bio =
88 case OpenSSL.readInt bio of
89 SOME 0 => SOME false
90 | SOME 1 => SOME true
91 | _ => NONE
92
93 fun sendSockPerm (bio, p) =
94 case p of
95 Any => OpenSSL.writeInt (bio, 0)
96 | Client => OpenSSL.writeInt (bio, 1)
97 | Server => OpenSSL.writeInt (bio, 2)
98 | Nada => OpenSSL.writeInt (bio, 3)
99
100 fun recvSockPerm bio =
101 case OpenSSL.readInt bio of
102 SOME 0 => SOME Any
103 | SOME 1 => SOME Client
104 | SOME 2 => SOME Server
105 | SOME 3 => SOME Nada
106 | _ => NONE
107
108 fun sendQuery (bio, q) =
109 case q of
110 QApt s => (OpenSSL.writeInt (bio, 0);
111 OpenSSL.writeString (bio, s))
112 | QCron s => (OpenSSL.writeInt (bio, 1);
113 OpenSSL.writeString (bio, s))
114 | QFtp s => (OpenSSL.writeInt (bio, 2);
115 OpenSSL.writeString (bio, s))
116 | QTrustedPath s => (OpenSSL.writeInt (bio, 3);
117 OpenSSL.writeString (bio, s))
118 | QSocket s => (OpenSSL.writeInt (bio, 4);
119 OpenSSL.writeString (bio, s))
120 | QFirewall {node, user} => (OpenSSL.writeInt (bio, 5);
121 OpenSSL.writeString (bio, node);
122 OpenSSL.writeString (bio, user))
123 | QAptExists s => (OpenSSL.writeInt (bio, 6);
124 OpenSSL.writeString (bio, s))
125
126 fun recvQuery bio =
127 case OpenSSL.readInt bio of
128 SOME n =>
129 (case n of
130 0 => Option.map QApt (OpenSSL.readString bio)
131 | 1 => Option.map QCron (OpenSSL.readString bio)
132 | 2 => Option.map QFtp (OpenSSL.readString bio)
133 | 3 => Option.map QTrustedPath (OpenSSL.readString bio)
134 | 4 => Option.map QSocket (OpenSSL.readString bio)
135 | 5 => (case ((OpenSSL.readString bio), (OpenSSL.readString bio)) of
136 (SOME node, SOME user) => SOME (QFirewall { node = node, user = user })
137 | _ => NONE)
138 | 6 => Option.map QAptExists (OpenSSL.readString bio)
139 | _ => NONE)
140 | NONE => NONE
141
142 fun send (bio, m) =
143 case m of
144 MsgOk => OpenSSL.writeInt (bio, 1)
145 | MsgError s => (OpenSSL.writeInt (bio, 2);
146 OpenSSL.writeString (bio, s))
147 | MsgConfig s => (OpenSSL.writeInt (bio, 3);
148 OpenSSL.writeString (bio, s))
149 | MsgFile {action, domain, dir, file} =>
150 (OpenSSL.writeInt (bio, 4);
151 OpenSSL.writeInt (bio, a2i action);
152 OpenSSL.writeString (bio, domain);
153 OpenSSL.writeString (bio, dir);
154 OpenSSL.writeString (bio, file))
155 | MsgDoFiles => OpenSSL.writeInt (bio, 5)
156 | MsgGrant acl => (OpenSSL.writeInt (bio, 6);
157 sendAcl (bio, acl))
158 | MsgRevoke acl => (OpenSSL.writeInt (bio, 7);
159 sendAcl (bio, acl))
160 | MsgListPerms user => (OpenSSL.writeInt (bio, 8);
161 OpenSSL.writeString (bio, user))
162 | MsgPerms classes => (OpenSSL.writeInt (bio, 9);
163 sendList (fn (bio, (class, values)) =>
164 (OpenSSL.writeString (bio, class);
165 sendList OpenSSL.writeString (bio, values)))
166 (bio, classes))
167 | MsgWhoHas {class, value} => (OpenSSL.writeInt (bio, 10);
168 OpenSSL.writeString (bio, class);
169 OpenSSL.writeString (bio, value))
170 | MsgWhoHasResponse users => (OpenSSL.writeInt (bio, 11);
171 sendList OpenSSL.writeString (bio, users))
172 | MsgMultiConfig codes => (OpenSSL.writeInt (bio, 12);
173 sendList OpenSSL.writeString (bio, codes))
174 | MsgRmdom doms => (OpenSSL.writeInt (bio, 13);
175 sendList OpenSSL.writeString (bio, doms))
176 | MsgRegenerate => OpenSSL.writeInt (bio, 14)
177 | MsgRmuser dom => (OpenSSL.writeInt (bio, 15);
178 OpenSSL.writeString (bio, dom))
179 | MsgCreateDbUser {dbtype, passwd} => (OpenSSL.writeInt (bio, 16);
180 OpenSSL.writeString (bio, dbtype);
181 sendOption OpenSSL.writeString (bio, passwd))
182 | MsgCreateDb {dbtype, dbname, encoding} => (OpenSSL.writeInt (bio, 17);
183 OpenSSL.writeString (bio, dbtype);
184 OpenSSL.writeString (bio, dbname);
185 sendOption OpenSSL.writeString (bio, encoding))
186 | MsgNewMailbox {domain, user, passwd, mailbox} =>
187 (OpenSSL.writeInt (bio, 18);
188 OpenSSL.writeString (bio, domain);
189 OpenSSL.writeString (bio, user);
190 OpenSSL.writeString (bio, passwd);
191 OpenSSL.writeString (bio, mailbox))
192 | MsgPasswdMailbox {domain, user, passwd} =>
193 (OpenSSL.writeInt (bio, 19);
194 OpenSSL.writeString (bio, domain);
195 OpenSSL.writeString (bio, user);
196 OpenSSL.writeString (bio, passwd))
197 | MsgRmMailbox {domain, user} =>
198 (OpenSSL.writeInt (bio, 20);
199 OpenSSL.writeString (bio, domain);
200 OpenSSL.writeString (bio, user))
201 | MsgListMailboxes domain =>
202 (OpenSSL.writeInt (bio, 21);
203 OpenSSL.writeString (bio, domain))
204 | MsgMailboxes users =>
205 (OpenSSL.writeInt (bio, 22);
206 sendList (fn (bio, {user, mailbox}) =>
207 (OpenSSL.writeString (bio, user);
208 OpenSSL.writeString (bio, mailbox)))
209 (bio, users))
210 | MsgSaQuery addr => (OpenSSL.writeInt (bio, 23);
211 OpenSSL.writeString (bio, addr))
212 | MsgSaStatus b => (OpenSSL.writeInt (bio, 24);
213 sendBool (bio, b))
214 | MsgSaSet (addr, b) => (OpenSSL.writeInt (bio, 25);
215 OpenSSL.writeString (bio, addr);
216 sendBool (bio, b))
217 | MsgSmtpLogReq domain => (OpenSSL.writeInt (bio, 26);
218 OpenSSL.writeString (bio, domain))
219 | MsgSmtpLogRes domain => (OpenSSL.writeInt (bio, 27);
220 OpenSSL.writeString (bio, domain))
221 | MsgDbPasswd {dbtype, passwd} => (OpenSSL.writeInt (bio, 28);
222 OpenSSL.writeString (bio, dbtype);
223 OpenSSL.writeString (bio, passwd))
224 | MsgShutdown => OpenSSL.writeInt (bio, 29)
225 | MsgYes => OpenSSL.writeInt (bio, 30)
226 | MsgNo => OpenSSL.writeInt (bio, 31)
227 | MsgQuery q => (OpenSSL.writeInt (bio, 32);
228 sendQuery (bio, q))
229 | MsgSocket p => (OpenSSL.writeInt (bio, 33);
230 sendSockPerm (bio, p))
231 | MsgFirewall ls => (OpenSSL.writeInt (bio, 34);
232 sendList OpenSSL.writeString (bio, ls))
233 | MsgRegenerateTc => OpenSSL.writeInt (bio, 35)
234 | MsgDropDb {dbtype, dbname} => (OpenSSL.writeInt (bio, 36);
235 OpenSSL.writeString (bio, dbtype);
236 OpenSSL.writeString (bio, dbname))
237 | MsgGrantDb {dbtype, dbname} => (OpenSSL.writeInt (bio, 37);
238 OpenSSL.writeString (bio, dbtype);
239 OpenSSL.writeString (bio, dbname))
240 | MsgMysqlFixperms => OpenSSL.writeInt (bio, 38)
241 | MsgDescribe dom => (OpenSSL.writeInt (bio, 39);
242 OpenSSL.writeString (bio, dom))
243 | MsgDescription s => (OpenSSL.writeInt (bio, 40);
244 OpenSSL.writeString (bio, s))
245 | MsgReUsers => OpenSSL.writeInt (bio, 41)
246 | MsgVmailChanged => OpenSSL.writeInt (bio, 42)
247 | MsgFirewallRegen => OpenSSL.writeInt (bio, 43)
248 | MsgAptQuery {section, description} => (OpenSSL.writeInt (bio, 44);
249 OpenSSL.writeString (bio, section);
250 OpenSSL.writeString (bio, description))
251
252 fun checkIt v =
253 case v of
254 NONE => raise OpenSSL.OpenSSL "Bad Msg format"
255 | _ => v
256
257 fun recv bio =
258 case OpenSSL.readInt bio of
259 NONE => NONE
260 | SOME n =>
261 checkIt (case n of
262 1 => SOME MsgOk
263 | 2 => Option.map MsgError (OpenSSL.readString bio)
264 | 3 => Option.map MsgConfig (OpenSSL.readString bio)
265 | 4 => (case (OpenSSL.readInt bio,
266 OpenSSL.readString bio,
267 OpenSSL.readString bio,
268 OpenSSL.readString bio) of
269 (SOME action, SOME domain, SOME dir, SOME file) =>
270 SOME (MsgFile {action = i2a action,
271 domain = domain,
272 dir = dir,
273 file = file})
274 | _ => NONE)
275 | 5 => SOME MsgDoFiles
276 | 6 => (case recvAcl bio of
277 SOME acl => SOME (MsgGrant acl)
278 | _ => NONE)
279 | 7 => (case recvAcl bio of
280 SOME acl => SOME (MsgRevoke acl)
281 | _ => NONE)
282 | 8 => (case OpenSSL.readString bio of
283 SOME user => SOME (MsgListPerms user)
284 | _ => NONE)
285 | 9 => Option.map MsgPerms
286 (recvList (fn bio =>
287 case (OpenSSL.readString bio,
288 recvList OpenSSL.readString bio) of
289 (SOME class, SOME values) => SOME (class, values)
290 | _ => NONE) bio)
291 | 10 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
292 (SOME class, SOME value) => SOME (MsgWhoHas {class = class, value = value})
293 | _ => NONE)
294 | 11 => Option.map MsgWhoHasResponse
295 (recvList OpenSSL.readString bio)
296 | 12 => Option.map MsgMultiConfig
297 (recvList OpenSSL.readString bio)
298 | 13 => Option.map MsgRmdom (recvList OpenSSL.readString bio)
299 | 14 => SOME MsgRegenerate
300 | 15 => Option.map MsgRmuser (OpenSSL.readString bio)
301 | 16 => (case (OpenSSL.readString bio, recvOption OpenSSL.readString bio) of
302 (SOME dbtype, SOME passwd) =>
303 SOME (MsgCreateDbUser {dbtype = dbtype, passwd = passwd})
304 | _ => NONE)
305 | 17 => (case (OpenSSL.readString bio, OpenSSL.readString bio, recvOption OpenSSL.readString bio) of
306 (SOME dbtype, SOME dbname, SOME encoding) =>
307 SOME (MsgCreateDb {dbtype = dbtype, dbname = dbname, encoding = encoding})
308 | _ => NONE)
309 | 18 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
310 OpenSSL.readString bio, OpenSSL.readString bio) of
311 (SOME domain, SOME user, SOME passwd, SOME mailbox) =>
312 SOME (MsgNewMailbox {domain = domain, user = user,
313 passwd = passwd, mailbox = mailbox})
314 | _ => NONE)
315 | 19 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
316 OpenSSL.readString bio) of
317 (SOME domain, SOME user, SOME passwd) =>
318 SOME (MsgPasswdMailbox {domain = domain, user = user,
319 passwd = passwd})
320 | _ => NONE)
321 | 20 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
322 (SOME domain, SOME user) =>
323 SOME (MsgRmMailbox {domain = domain, user = user})
324 | _ => NONE)
325 | 21 => Option.map MsgListMailboxes (OpenSSL.readString bio)
326 | 22 => Option.map MsgMailboxes (recvList
327 (fn bio =>
328 case (OpenSSL.readString bio,
329 OpenSSL.readString bio) of
330 (SOME user, SOME mailbox) =>
331 SOME {user = user, mailbox = mailbox}
332 | _ => NONE)
333 bio)
334 | 23 => Option.map MsgSaQuery (OpenSSL.readString bio)
335 | 24 => Option.map MsgSaStatus (recvBool bio)
336 | 25 => (case (OpenSSL.readString bio, recvBool bio) of
337 (SOME user, SOME b) => SOME (MsgSaSet (user, b))
338 | _ => NONE)
339 | 26 => Option.map MsgSmtpLogReq (OpenSSL.readString bio)
340 | 27 => Option.map MsgSmtpLogRes (OpenSSL.readString bio)
341 | 28 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
342 (SOME dbtype, SOME passwd) =>
343 SOME (MsgDbPasswd {dbtype = dbtype, passwd = passwd})
344 | _ => NONE)
345 | 29 => SOME MsgShutdown
346 | 30 => SOME MsgYes
347 | 31 => SOME MsgNo
348 | 32 => Option.map MsgQuery (recvQuery bio)
349 | 33 => Option.map MsgSocket (recvSockPerm bio)
350 | 34 => Option.map MsgFirewall (recvList OpenSSL.readString bio)
351 | 35 => SOME MsgRegenerateTc
352 | 36 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
353 (SOME dbtype, SOME dbname) =>
354 SOME (MsgDropDb {dbtype = dbtype, dbname = dbname})
355 | _ => NONE)
356 | 37 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
357 (SOME dbtype, SOME dbname) =>
358 SOME (MsgGrantDb {dbtype = dbtype, dbname = dbname})
359 | _ => NONE)
360 | 38 => SOME MsgMysqlFixperms
361 | 39 => Option.map MsgDescribe (OpenSSL.readString bio)
362 | 40 => Option.map MsgDescription (OpenSSL.readString bio)
363 | 41 => SOME MsgReUsers
364 | 42 => SOME MsgVmailChanged
365 | 43 => SOME MsgFirewallRegen
366 | 44 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
367 (SOME section, SOME description) => SOME (MsgAptQuery {section = section, description = description})
368 | _ => NONE)
369 | _ => NONE)
370
371 end