5940bbe54302eef1e6ef9566f2d01c3373b6baa4
[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 => 1
27 | Modify => 2
28
29 val i2a = fn 0 => Add
30 | 1 => Delete
31 | 2 => Modify
32 | _ => raise OpenSSL.OpenSSL "Bad action number to deserialize"
33
34 fun sendAcl (bio, {user, class, value}) =
35 (OpenSSL.writeString (bio, user);
36 OpenSSL.writeString (bio, class);
37 OpenSSL.writeString (bio, value))
38
39 fun recvAcl bio =
40 case (OpenSSL.readString bio, OpenSSL.readString bio, OpenSSL.readString bio) of
41 (SOME user, SOME class, SOME value) => SOME {user = user, class = class, value = value}
42 | _ => NONE
43
44 fun sendList f (bio, ls) =
45 (app (fn x =>
46 (OpenSSL.writeInt (bio, 1);
47 f (bio, x))) ls;
48 OpenSSL.writeInt (bio, 0))
49
50 fun recvList f bio =
51 let
52 fun loop ls =
53 case OpenSSL.readInt bio of
54 SOME 0 => SOME (rev ls)
55 | SOME 1 =>
56 (case f bio of
57 SOME x => loop (x :: ls)
58 | NONE => NONE)
59 | _ => NONE
60 in
61 loop []
62 end
63
64 fun sendOption f (bio, opt) =
65 case opt of
66 NONE => OpenSSL.writeInt (bio, 0)
67 | SOME x => (OpenSSL.writeInt (bio, 1);
68 f (bio, x))
69
70 fun recvOption f bio =
71 case OpenSSL.readInt bio of
72 SOME 0 => SOME NONE
73 | SOME 1 =>
74 (case f bio of
75 SOME x => SOME (SOME x)
76 | NONE => NONE)
77 | _ => NONE
78
79 fun sendBool (bio, b) =
80 if b then
81 OpenSSL.writeInt (bio, 1)
82 else
83 OpenSSL.writeInt (bio, 0)
84
85 fun recvBool bio =
86 case OpenSSL.readInt bio of
87 SOME 0 => SOME false
88 | SOME 1 => SOME true
89 | _ => NONE
90
91 fun sendSockPerm (bio, p) =
92 case p of
93 Any => OpenSSL.writeInt (bio, 0)
94 | Client => OpenSSL.writeInt (bio, 1)
95 | Server => OpenSSL.writeInt (bio, 2)
96 | Nada => OpenSSL.writeInt (bio, 3)
97
98 fun recvSockPerm bio =
99 case OpenSSL.readInt bio of
100 SOME 0 => SOME Any
101 | SOME 1 => SOME Client
102 | SOME 2 => SOME Server
103 | SOME 3 => SOME Nada
104 | _ => NONE
105
106 fun sendQuery (bio, q) =
107 case q of
108 QApt s => (OpenSSL.writeInt (bio, 0);
109 OpenSSL.writeString (bio, s))
110 | QCron s => (OpenSSL.writeInt (bio, 1);
111 OpenSSL.writeString (bio, s))
112 | QFtp s => (OpenSSL.writeInt (bio, 2);
113 OpenSSL.writeString (bio, s))
114 | QTrustedPath s => (OpenSSL.writeInt (bio, 3);
115 OpenSSL.writeString (bio, s))
116 | QSocket s => (OpenSSL.writeInt (bio, 4);
117 OpenSSL.writeString (bio, s))
118 | QFirewall s => (OpenSSL.writeInt (bio, 5);
119 OpenSSL.writeString (bio, s))
120
121 fun recvQuery bio =
122 case OpenSSL.readInt bio of
123 SOME n =>
124 (case n of
125 0 => Option.map QApt (OpenSSL.readString bio)
126 | 1 => Option.map QCron (OpenSSL.readString bio)
127 | 2 => Option.map QFtp (OpenSSL.readString bio)
128 | 3 => Option.map QTrustedPath (OpenSSL.readString bio)
129 | 4 => Option.map QSocket (OpenSSL.readString bio)
130 | 5 => Option.map QFirewall (OpenSSL.readString bio)
131 | _ => NONE)
132 | NONE => NONE
133
134 fun send (bio, m) =
135 case m of
136 MsgOk => OpenSSL.writeInt (bio, 1)
137 | MsgError s => (OpenSSL.writeInt (bio, 2);
138 OpenSSL.writeString (bio, s))
139 | MsgConfig s => (OpenSSL.writeInt (bio, 3);
140 OpenSSL.writeString (bio, s))
141 | MsgFile {action, domain, dir, file} =>
142 (OpenSSL.writeInt (bio, 4);
143 OpenSSL.writeInt (bio, a2i action);
144 OpenSSL.writeString (bio, domain);
145 OpenSSL.writeString (bio, dir);
146 OpenSSL.writeString (bio, file))
147 | MsgDoFiles => OpenSSL.writeInt (bio, 5)
148 | MsgGrant acl => (OpenSSL.writeInt (bio, 6);
149 sendAcl (bio, acl))
150 | MsgRevoke acl => (OpenSSL.writeInt (bio, 7);
151 sendAcl (bio, acl))
152 | MsgListPerms user => (OpenSSL.writeInt (bio, 8);
153 OpenSSL.writeString (bio, user))
154 | MsgPerms classes => (OpenSSL.writeInt (bio, 9);
155 sendList (fn (bio, (class, values)) =>
156 (OpenSSL.writeString (bio, class);
157 sendList OpenSSL.writeString (bio, values)))
158 (bio, classes))
159 | MsgWhoHas {class, value} => (OpenSSL.writeInt (bio, 10);
160 OpenSSL.writeString (bio, class);
161 OpenSSL.writeString (bio, value))
162 | MsgWhoHasResponse users => (OpenSSL.writeInt (bio, 11);
163 sendList OpenSSL.writeString (bio, users))
164 | MsgMultiConfig codes => (OpenSSL.writeInt (bio, 12);
165 sendList OpenSSL.writeString (bio, codes))
166 | MsgRmdom doms => (OpenSSL.writeInt (bio, 13);
167 sendList OpenSSL.writeString (bio, doms))
168 | MsgRegenerate => OpenSSL.writeInt (bio, 14)
169 | MsgRmuser dom => (OpenSSL.writeInt (bio, 15);
170 OpenSSL.writeString (bio, dom))
171 | MsgCreateDbUser {dbtype, passwd} => (OpenSSL.writeInt (bio, 16);
172 OpenSSL.writeString (bio, dbtype);
173 sendOption OpenSSL.writeString (bio, passwd))
174 | MsgCreateDb {dbtype, dbname} => (OpenSSL.writeInt (bio, 17);
175 OpenSSL.writeString (bio, dbtype);
176 OpenSSL.writeString (bio, dbname))
177 | MsgNewMailbox {domain, user, passwd, mailbox} =>
178 (OpenSSL.writeInt (bio, 18);
179 OpenSSL.writeString (bio, domain);
180 OpenSSL.writeString (bio, user);
181 OpenSSL.writeString (bio, passwd);
182 OpenSSL.writeString (bio, mailbox))
183 | MsgPasswdMailbox {domain, user, passwd} =>
184 (OpenSSL.writeInt (bio, 19);
185 OpenSSL.writeString (bio, domain);
186 OpenSSL.writeString (bio, user);
187 OpenSSL.writeString (bio, passwd))
188 | MsgRmMailbox {domain, user} =>
189 (OpenSSL.writeInt (bio, 20);
190 OpenSSL.writeString (bio, domain);
191 OpenSSL.writeString (bio, user))
192 | MsgListMailboxes domain =>
193 (OpenSSL.writeInt (bio, 21);
194 OpenSSL.writeString (bio, domain))
195 | MsgMailboxes users =>
196 (OpenSSL.writeInt (bio, 22);
197 sendList (fn (bio, {user, mailbox}) =>
198 (OpenSSL.writeString (bio, user);
199 OpenSSL.writeString (bio, mailbox)))
200 (bio, users))
201 | MsgSaQuery addr => (OpenSSL.writeInt (bio, 23);
202 OpenSSL.writeString (bio, addr))
203 | MsgSaStatus b => (OpenSSL.writeInt (bio, 24);
204 sendBool (bio, b))
205 | MsgSaSet (addr, b) => (OpenSSL.writeInt (bio, 25);
206 OpenSSL.writeString (bio, addr);
207 sendBool (bio, b))
208 | MsgSmtpLogReq domain => (OpenSSL.writeInt (bio, 26);
209 OpenSSL.writeString (bio, domain))
210 | MsgSmtpLogRes domain => (OpenSSL.writeInt (bio, 27);
211 OpenSSL.writeString (bio, domain))
212 | MsgDbPasswd {dbtype, passwd} => (OpenSSL.writeInt (bio, 28);
213 OpenSSL.writeString (bio, dbtype);
214 OpenSSL.writeString (bio, passwd))
215 | MsgShutdown => OpenSSL.writeInt (bio, 29)
216 | MsgYes => OpenSSL.writeInt (bio, 30)
217 | MsgNo => OpenSSL.writeInt (bio, 31)
218 | MsgQuery q => (OpenSSL.writeInt (bio, 32);
219 sendQuery (bio, q))
220 | MsgSocket p => (OpenSSL.writeInt (bio, 33);
221 sendSockPerm (bio, p))
222 | MsgFirewall ls => (OpenSSL.writeInt (bio, 34);
223 sendList OpenSSL.writeString (bio, ls))
224 | MsgRegenerateTc => OpenSSL.writeInt (bio, 35)
225 | MsgDropDb {dbtype, dbname} => (OpenSSL.writeInt (bio, 36);
226 OpenSSL.writeString (bio, dbtype);
227 OpenSSL.writeString (bio, dbname))
228 | MsgGrantDb {dbtype, dbname} => (OpenSSL.writeInt (bio, 37);
229 OpenSSL.writeString (bio, dbtype);
230 OpenSSL.writeString (bio, dbname))
231 | MsgMysqlFixperms => OpenSSL.writeInt (bio, 38)
232 | MsgDescribe dom => (OpenSSL.writeInt (bio, 39);
233 OpenSSL.writeString (bio, dom))
234 | MsgDescription s => (OpenSSL.writeInt (bio, 40);
235 OpenSSL.writeString (bio, s))
236
237 fun checkIt v =
238 case v of
239 NONE => raise OpenSSL.OpenSSL "Bad Msg format"
240 | _ => v
241
242 fun recv bio =
243 case OpenSSL.readInt bio of
244 NONE => NONE
245 | SOME n =>
246 checkIt (case n of
247 1 => SOME MsgOk
248 | 2 => Option.map MsgError (OpenSSL.readString bio)
249 | 3 => Option.map MsgConfig (OpenSSL.readString bio)
250 | 4 => (case (OpenSSL.readInt bio,
251 OpenSSL.readString bio,
252 OpenSSL.readString bio,
253 OpenSSL.readString bio) of
254 (SOME action, SOME domain, SOME dir, SOME file) =>
255 SOME (MsgFile {action = i2a action,
256 domain = domain,
257 dir = dir,
258 file = file})
259 | _ => NONE)
260 | 5 => SOME MsgDoFiles
261 | 6 => (case recvAcl bio of
262 SOME acl => SOME (MsgGrant acl)
263 | _ => NONE)
264 | 7 => (case recvAcl bio of
265 SOME acl => SOME (MsgRevoke acl)
266 | _ => NONE)
267 | 8 => (case OpenSSL.readString bio of
268 SOME user => SOME (MsgListPerms user)
269 | _ => NONE)
270 | 9 => Option.map MsgPerms
271 (recvList (fn bio =>
272 case (OpenSSL.readString bio,
273 recvList OpenSSL.readString bio) of
274 (SOME class, SOME values) => SOME (class, values)
275 | _ => NONE) bio)
276 | 10 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
277 (SOME class, SOME value) => SOME (MsgWhoHas {class = class, value = value})
278 | _ => NONE)
279 | 11 => Option.map MsgWhoHasResponse
280 (recvList OpenSSL.readString bio)
281 | 12 => Option.map MsgMultiConfig
282 (recvList OpenSSL.readString bio)
283 | 13 => Option.map MsgRmdom (recvList OpenSSL.readString bio)
284 | 14 => SOME MsgRegenerate
285 | 15 => Option.map MsgRmuser (OpenSSL.readString bio)
286 | 16 => (case (OpenSSL.readString bio, recvOption OpenSSL.readString bio) of
287 (SOME dbtype, SOME passwd) =>
288 SOME (MsgCreateDbUser {dbtype = dbtype, passwd = passwd})
289 | _ => NONE)
290 | 17 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
291 (SOME dbtype, SOME dbname) =>
292 SOME (MsgCreateDb {dbtype = dbtype, dbname = dbname})
293 | _ => NONE)
294 | 18 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
295 OpenSSL.readString bio, OpenSSL.readString bio) of
296 (SOME domain, SOME user, SOME passwd, SOME mailbox) =>
297 SOME (MsgNewMailbox {domain = domain, user = user,
298 passwd = passwd, mailbox = mailbox})
299 | _ => NONE)
300 | 19 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
301 OpenSSL.readString bio) of
302 (SOME domain, SOME user, SOME passwd) =>
303 SOME (MsgPasswdMailbox {domain = domain, user = user,
304 passwd = passwd})
305 | _ => NONE)
306 | 20 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
307 (SOME domain, SOME user) =>
308 SOME (MsgRmMailbox {domain = domain, user = user})
309 | _ => NONE)
310 | 21 => Option.map MsgListMailboxes (OpenSSL.readString bio)
311 | 22 => Option.map MsgMailboxes (recvList
312 (fn bio =>
313 case (OpenSSL.readString bio,
314 OpenSSL.readString bio) of
315 (SOME user, SOME mailbox) =>
316 SOME {user = user, mailbox = mailbox}
317 | _ => NONE)
318 bio)
319 | 23 => Option.map MsgSaQuery (OpenSSL.readString bio)
320 | 24 => Option.map MsgSaStatus (recvBool bio)
321 | 25 => (case (OpenSSL.readString bio, recvBool bio) of
322 (SOME user, SOME b) => SOME (MsgSaSet (user, b))
323 | _ => NONE)
324 | 26 => Option.map MsgSmtpLogReq (OpenSSL.readString bio)
325 | 27 => Option.map MsgSmtpLogRes (OpenSSL.readString bio)
326 | 28 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
327 (SOME dbtype, SOME passwd) =>
328 SOME (MsgDbPasswd {dbtype = dbtype, passwd = passwd})
329 | _ => NONE)
330 | 29 => SOME MsgShutdown
331 | 30 => SOME MsgYes
332 | 31 => SOME MsgNo
333 | 32 => Option.map MsgQuery (recvQuery bio)
334 | 33 => Option.map MsgSocket (recvSockPerm bio)
335 | 34 => Option.map MsgFirewall (recvList OpenSSL.readString bio)
336 | 35 => SOME MsgRegenerateTc
337 | 36 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
338 (SOME dbtype, SOME dbname) =>
339 SOME (MsgDropDb {dbtype = dbtype, dbname = dbname})
340 | _ => NONE)
341 | 37 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
342 (SOME dbtype, SOME dbname) =>
343 SOME (MsgGrantDb {dbtype = dbtype, dbname = dbname})
344 | _ => NONE)
345 | 38 => SOME MsgMysqlFixperms
346 | 39 => Option.map MsgDescribe (OpenSSL.readString bio)
347 | 40 => Option.map MsgDescription (OpenSSL.readString bio)
348 | _ => NONE)
349
350 end