Overhaul fwtool
[hcoop/domtool2.git] / src / msg.sml
CommitLineData
36e42cb8
AC
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
21structure Msg :> MSG = struct
22
23open OpenSSL MsgTypes Slave
24
25val a2i = fn Add => 0
1638d5a2 26 | Delete true => 1
36e42cb8 27 | Modify => 2
1638d5a2 28 | Delete false => 3
36e42cb8
AC
29
30val i2a = fn 0 => Add
1638d5a2 31 | 1 => Delete true
36e42cb8 32 | 2 => Modify
1638d5a2 33 | 3 => Delete false
36e42cb8
AC
34 | _ => raise OpenSSL.OpenSSL "Bad action number to deserialize"
35
5ee41dd0
AC
36fun sendAcl (bio, {user, class, value}) =
37 (OpenSSL.writeString (bio, user);
38 OpenSSL.writeString (bio, class);
39 OpenSSL.writeString (bio, value))
40
41fun 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
c53e82e4
AC
46fun sendList f (bio, ls) =
47 (app (fn x =>
48 (OpenSSL.writeInt (bio, 1);
49 f (bio, x))) ls;
50 OpenSSL.writeInt (bio, 0))
51
52fun 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
21d921a5
AC
66fun 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
72fun 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
2e96b9d4
AC
81fun sendBool (bio, b) =
82 if b then
83 OpenSSL.writeInt (bio, 1)
84 else
85 OpenSSL.writeInt (bio, 0)
86
87fun recvBool bio =
88 case OpenSSL.readInt bio of
89 SOME 0 => SOME false
90 | SOME 1 => SOME true
91 | _ => NONE
92
737c68d4
AC
93fun 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
100fun 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
a95a0107
AC
108fun sendQuery (bio, q) =
109 case q of
110 QApt s => (OpenSSL.writeInt (bio, 0);
111 OpenSSL.writeString (bio, s))
d351d679
AC
112 | QCron s => (OpenSSL.writeInt (bio, 1);
113 OpenSSL.writeString (bio, s))
114 | QFtp s => (OpenSSL.writeInt (bio, 2);
115 OpenSSL.writeString (bio, s))
4d5126e1
AC
116 | QTrustedPath s => (OpenSSL.writeInt (bio, 3);
117 OpenSSL.writeString (bio, s))
737c68d4
AC
118 | QSocket s => (OpenSSL.writeInt (bio, 4);
119 OpenSSL.writeString (bio, s))
f9548f16
AC
120 | QFirewall s => (OpenSSL.writeInt (bio, 5);
121 OpenSSL.writeString (bio, s))
991d8e66
CE
122 | QAptExists s => (OpenSSL.writeInt (bio, 6);
123 OpenSSL.writeString (bio, s))
a95a0107
AC
124
125fun recvQuery bio =
126 case OpenSSL.readInt bio of
127 SOME n =>
128 (case n of
129 0 => Option.map QApt (OpenSSL.readString bio)
d351d679
AC
130 | 1 => Option.map QCron (OpenSSL.readString bio)
131 | 2 => Option.map QFtp (OpenSSL.readString bio)
4d5126e1 132 | 3 => Option.map QTrustedPath (OpenSSL.readString bio)
737c68d4 133 | 4 => Option.map QSocket (OpenSSL.readString bio)
f9548f16 134 | 5 => Option.map QFirewall (OpenSSL.readString bio)
991d8e66 135 | 6 => Option.map QAptExists (OpenSSL.readString bio)
a95a0107
AC
136 | _ => NONE)
137 | NONE => NONE
138
36e42cb8
AC
139fun send (bio, m) =
140 case m of
141 MsgOk => OpenSSL.writeInt (bio, 1)
142 | MsgError s => (OpenSSL.writeInt (bio, 2);
143 OpenSSL.writeString (bio, s))
144 | MsgConfig s => (OpenSSL.writeInt (bio, 3);
145 OpenSSL.writeString (bio, s))
146 | MsgFile {action, domain, dir, file} =>
147 (OpenSSL.writeInt (bio, 4);
148 OpenSSL.writeInt (bio, a2i action);
149 OpenSSL.writeString (bio, domain);
150 OpenSSL.writeString (bio, dir);
151 OpenSSL.writeString (bio, file))
152 | MsgDoFiles => OpenSSL.writeInt (bio, 5)
5ee41dd0
AC
153 | MsgGrant acl => (OpenSSL.writeInt (bio, 6);
154 sendAcl (bio, acl))
411a85f2
AC
155 | MsgRevoke acl => (OpenSSL.writeInt (bio, 7);
156 sendAcl (bio, acl))
08a04eb4
AC
157 | MsgListPerms user => (OpenSSL.writeInt (bio, 8);
158 OpenSSL.writeString (bio, user))
159 | MsgPerms classes => (OpenSSL.writeInt (bio, 9);
c53e82e4
AC
160 sendList (fn (bio, (class, values)) =>
161 (OpenSSL.writeString (bio, class);
162 sendList OpenSSL.writeString (bio, values)))
163 (bio, classes))
094877b1
AC
164 | MsgWhoHas {class, value} => (OpenSSL.writeInt (bio, 10);
165 OpenSSL.writeString (bio, class);
166 OpenSSL.writeString (bio, value))
167 | MsgWhoHasResponse users => (OpenSSL.writeInt (bio, 11);
c53e82e4
AC
168 sendList OpenSSL.writeString (bio, users))
169 | MsgMultiConfig codes => (OpenSSL.writeInt (bio, 12);
170 sendList OpenSSL.writeString (bio, codes))
e69e60cc
AC
171 | MsgRmdom doms => (OpenSSL.writeInt (bio, 13);
172 sendList OpenSSL.writeString (bio, doms))
1824f573 173 | MsgRegenerate => OpenSSL.writeInt (bio, 14)
e69e60cc
AC
174 | MsgRmuser dom => (OpenSSL.writeInt (bio, 15);
175 OpenSSL.writeString (bio, dom))
21d921a5
AC
176 | MsgCreateDbUser {dbtype, passwd} => (OpenSSL.writeInt (bio, 16);
177 OpenSSL.writeString (bio, dbtype);
178 sendOption OpenSSL.writeString (bio, passwd))
fe789bea
AC
179 | MsgCreateDb {dbtype, dbname, encoding} => (OpenSSL.writeInt (bio, 17);
180 OpenSSL.writeString (bio, dbtype);
181 OpenSSL.writeString (bio, dbname);
182 sendOption OpenSSL.writeString (bio, encoding))
08688401
AC
183 | MsgNewMailbox {domain, user, passwd, mailbox} =>
184 (OpenSSL.writeInt (bio, 18);
185 OpenSSL.writeString (bio, domain);
186 OpenSSL.writeString (bio, user);
187 OpenSSL.writeString (bio, passwd);
188 OpenSSL.writeString (bio, mailbox))
189 | MsgPasswdMailbox {domain, user, passwd} =>
190 (OpenSSL.writeInt (bio, 19);
191 OpenSSL.writeString (bio, domain);
192 OpenSSL.writeString (bio, user);
193 OpenSSL.writeString (bio, passwd))
194 | MsgRmMailbox {domain, user} =>
195 (OpenSSL.writeInt (bio, 20);
196 OpenSSL.writeString (bio, domain);
197 OpenSSL.writeString (bio, user))
1d3ef80e
AC
198 | MsgListMailboxes domain =>
199 (OpenSSL.writeInt (bio, 21);
200 OpenSSL.writeString (bio, domain))
201 | MsgMailboxes users =>
202 (OpenSSL.writeInt (bio, 22);
2fc6b0dd
AC
203 sendList (fn (bio, {user, mailbox}) =>
204 (OpenSSL.writeString (bio, user);
205 OpenSSL.writeString (bio, mailbox)))
206 (bio, users))
2e96b9d4
AC
207 | MsgSaQuery addr => (OpenSSL.writeInt (bio, 23);
208 OpenSSL.writeString (bio, addr))
209 | MsgSaStatus b => (OpenSSL.writeInt (bio, 24);
210 sendBool (bio, b))
211 | MsgSaSet (addr, b) => (OpenSSL.writeInt (bio, 25);
212 OpenSSL.writeString (bio, addr);
213 sendBool (bio, b))
2bc5ed22
AC
214 | MsgSmtpLogReq domain => (OpenSSL.writeInt (bio, 26);
215 OpenSSL.writeString (bio, domain))
216 | MsgSmtpLogRes domain => (OpenSSL.writeInt (bio, 27);
217 OpenSSL.writeString (bio, domain))
86aa5de7
AC
218 | MsgDbPasswd {dbtype, passwd} => (OpenSSL.writeInt (bio, 28);
219 OpenSSL.writeString (bio, dbtype);
220 OpenSSL.writeString (bio, passwd))
9f27d58f 221 | MsgShutdown => OpenSSL.writeInt (bio, 29)
75585a67
AC
222 | MsgYes => OpenSSL.writeInt (bio, 30)
223 | MsgNo => OpenSSL.writeInt (bio, 31)
a95a0107
AC
224 | MsgQuery q => (OpenSSL.writeInt (bio, 32);
225 sendQuery (bio, q))
737c68d4
AC
226 | MsgSocket p => (OpenSSL.writeInt (bio, 33);
227 sendSockPerm (bio, p))
f9548f16
AC
228 | MsgFirewall ls => (OpenSSL.writeInt (bio, 34);
229 sendList OpenSSL.writeString (bio, ls))
fb6fac97 230 | MsgRegenerateTc => OpenSSL.writeInt (bio, 35)
35659203
AC
231 | MsgDropDb {dbtype, dbname} => (OpenSSL.writeInt (bio, 36);
232 OpenSSL.writeString (bio, dbtype);
233 OpenSSL.writeString (bio, dbname))
99cc4144
AC
234 | MsgGrantDb {dbtype, dbname} => (OpenSSL.writeInt (bio, 37);
235 OpenSSL.writeString (bio, dbtype);
236 OpenSSL.writeString (bio, dbname))
314ce7bd 237 | MsgMysqlFixperms => OpenSSL.writeInt (bio, 38)
1ffc47a6
AC
238 | MsgDescribe dom => (OpenSSL.writeInt (bio, 39);
239 OpenSSL.writeString (bio, dom))
240 | MsgDescription s => (OpenSSL.writeInt (bio, 40);
241 OpenSSL.writeString (bio, s))
563e7792 242 | MsgReUsers => OpenSSL.writeInt (bio, 41)
9b8c6dc8 243 | MsgVmailChanged => OpenSSL.writeInt (bio, 42)
73b95423 244 | MsgFirewallRegen => OpenSSL.writeInt (bio, 43)
f296c496
CE
245 | MsgAptQuery {section, description} => (OpenSSL.writeInt (bio, 44);
246 OpenSSL.writeString (bio, section);
247 OpenSSL.writeString (bio, description))
36e42cb8
AC
248
249fun checkIt v =
250 case v of
251 NONE => raise OpenSSL.OpenSSL "Bad Msg format"
252 | _ => v
253
254fun recv bio =
255 case OpenSSL.readInt bio of
256 NONE => NONE
257 | SOME n =>
258 checkIt (case n of
259 1 => SOME MsgOk
260 | 2 => Option.map MsgError (OpenSSL.readString bio)
261 | 3 => Option.map MsgConfig (OpenSSL.readString bio)
262 | 4 => (case (OpenSSL.readInt bio,
263 OpenSSL.readString bio,
264 OpenSSL.readString bio,
265 OpenSSL.readString bio) of
266 (SOME action, SOME domain, SOME dir, SOME file) =>
267 SOME (MsgFile {action = i2a action,
268 domain = domain,
269 dir = dir,
270 file = file})
271 | _ => NONE)
272 | 5 => SOME MsgDoFiles
5ee41dd0
AC
273 | 6 => (case recvAcl bio of
274 SOME acl => SOME (MsgGrant acl)
275 | _ => NONE)
411a85f2
AC
276 | 7 => (case recvAcl bio of
277 SOME acl => SOME (MsgRevoke acl)
278 | _ => NONE)
08a04eb4
AC
279 | 8 => (case OpenSSL.readString bio of
280 SOME user => SOME (MsgListPerms user)
281 | _ => NONE)
c53e82e4
AC
282 | 9 => Option.map MsgPerms
283 (recvList (fn bio =>
284 case (OpenSSL.readString bio,
285 recvList OpenSSL.readString bio) of
286 (SOME class, SOME values) => SOME (class, values)
287 | _ => NONE) bio)
094877b1
AC
288 | 10 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
289 (SOME class, SOME value) => SOME (MsgWhoHas {class = class, value = value})
290 | _ => NONE)
c53e82e4
AC
291 | 11 => Option.map MsgWhoHasResponse
292 (recvList OpenSSL.readString bio)
293 | 12 => Option.map MsgMultiConfig
294 (recvList OpenSSL.readString bio)
e69e60cc 295 | 13 => Option.map MsgRmdom (recvList OpenSSL.readString bio)
1824f573 296 | 14 => SOME MsgRegenerate
e69e60cc 297 | 15 => Option.map MsgRmuser (OpenSSL.readString bio)
21d921a5
AC
298 | 16 => (case (OpenSSL.readString bio, recvOption OpenSSL.readString bio) of
299 (SOME dbtype, SOME passwd) =>
300 SOME (MsgCreateDbUser {dbtype = dbtype, passwd = passwd})
301 | _ => NONE)
fe789bea
AC
302 | 17 => (case (OpenSSL.readString bio, OpenSSL.readString bio, recvOption OpenSSL.readString bio) of
303 (SOME dbtype, SOME dbname, SOME encoding) =>
304 SOME (MsgCreateDb {dbtype = dbtype, dbname = dbname, encoding = encoding})
90dd48df 305 | _ => NONE)
08688401
AC
306 | 18 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
307 OpenSSL.readString bio, OpenSSL.readString bio) of
308 (SOME domain, SOME user, SOME passwd, SOME mailbox) =>
309 SOME (MsgNewMailbox {domain = domain, user = user,
310 passwd = passwd, mailbox = mailbox})
311 | _ => NONE)
312 | 19 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
313 OpenSSL.readString bio) of
314 (SOME domain, SOME user, SOME passwd) =>
315 SOME (MsgPasswdMailbox {domain = domain, user = user,
316 passwd = passwd})
317 | _ => NONE)
318 | 20 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
319 (SOME domain, SOME user) =>
320 SOME (MsgRmMailbox {domain = domain, user = user})
321 | _ => NONE)
1d3ef80e 322 | 21 => Option.map MsgListMailboxes (OpenSSL.readString bio)
2fc6b0dd
AC
323 | 22 => Option.map MsgMailboxes (recvList
324 (fn bio =>
325 case (OpenSSL.readString bio,
326 OpenSSL.readString bio) of
327 (SOME user, SOME mailbox) =>
328 SOME {user = user, mailbox = mailbox}
329 | _ => NONE)
330 bio)
2e96b9d4
AC
331 | 23 => Option.map MsgSaQuery (OpenSSL.readString bio)
332 | 24 => Option.map MsgSaStatus (recvBool bio)
333 | 25 => (case (OpenSSL.readString bio, recvBool bio) of
334 (SOME user, SOME b) => SOME (MsgSaSet (user, b))
335 | _ => NONE)
2bc5ed22
AC
336 | 26 => Option.map MsgSmtpLogReq (OpenSSL.readString bio)
337 | 27 => Option.map MsgSmtpLogRes (OpenSSL.readString bio)
86aa5de7
AC
338 | 28 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
339 (SOME dbtype, SOME passwd) =>
340 SOME (MsgDbPasswd {dbtype = dbtype, passwd = passwd})
341 | _ => NONE)
9f27d58f 342 | 29 => SOME MsgShutdown
75585a67
AC
343 | 30 => SOME MsgYes
344 | 31 => SOME MsgNo
a95a0107 345 | 32 => Option.map MsgQuery (recvQuery bio)
737c68d4 346 | 33 => Option.map MsgSocket (recvSockPerm bio)
f9548f16 347 | 34 => Option.map MsgFirewall (recvList OpenSSL.readString bio)
fb6fac97 348 | 35 => SOME MsgRegenerateTc
35659203
AC
349 | 36 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
350 (SOME dbtype, SOME dbname) =>
351 SOME (MsgDropDb {dbtype = dbtype, dbname = dbname})
352 | _ => NONE)
99cc4144
AC
353 | 37 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
354 (SOME dbtype, SOME dbname) =>
355 SOME (MsgGrantDb {dbtype = dbtype, dbname = dbname})
356 | _ => NONE)
00a077ab 357 | 38 => SOME MsgMysqlFixperms
1ffc47a6
AC
358 | 39 => Option.map MsgDescribe (OpenSSL.readString bio)
359 | 40 => Option.map MsgDescription (OpenSSL.readString bio)
563e7792 360 | 41 => SOME MsgReUsers
9b8c6dc8 361 | 42 => SOME MsgVmailChanged
73b95423 362 | 43 => SOME MsgFirewallRegen
f296c496
CE
363 | 44 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
364 (SOME section, SOME description) => SOME (MsgAptQuery {section = section, description = description})
365 | _ => NONE)
36e42cb8
AC
366 | _ => NONE)
367
368end