Socket permission querying
[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
26 | Delete => 1
27 | Modify => 2
28
29val i2a = fn 0 => Add
30 | 1 => Delete
31 | 2 => Modify
32 | _ => raise OpenSSL.OpenSSL "Bad action number to deserialize"
33
5ee41dd0
AC
34fun sendAcl (bio, {user, class, value}) =
35 (OpenSSL.writeString (bio, user);
36 OpenSSL.writeString (bio, class);
37 OpenSSL.writeString (bio, value))
38
39fun 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
c53e82e4
AC
44fun sendList f (bio, ls) =
45 (app (fn x =>
46 (OpenSSL.writeInt (bio, 1);
47 f (bio, x))) ls;
48 OpenSSL.writeInt (bio, 0))
49
50fun 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
21d921a5
AC
64fun 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
70fun 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
2e96b9d4
AC
79fun sendBool (bio, b) =
80 if b then
81 OpenSSL.writeInt (bio, 1)
82 else
83 OpenSSL.writeInt (bio, 0)
84
85fun recvBool bio =
86 case OpenSSL.readInt bio of
87 SOME 0 => SOME false
88 | SOME 1 => SOME true
89 | _ => NONE
90
737c68d4
AC
91fun 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
98fun 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
a95a0107
AC
106fun sendQuery (bio, q) =
107 case q of
108 QApt s => (OpenSSL.writeInt (bio, 0);
109 OpenSSL.writeString (bio, s))
d351d679
AC
110 | QCron s => (OpenSSL.writeInt (bio, 1);
111 OpenSSL.writeString (bio, s))
112 | QFtp s => (OpenSSL.writeInt (bio, 2);
113 OpenSSL.writeString (bio, s))
4d5126e1
AC
114 | QTrustedPath s => (OpenSSL.writeInt (bio, 3);
115 OpenSSL.writeString (bio, s))
737c68d4
AC
116 | QSocket s => (OpenSSL.writeInt (bio, 4);
117 OpenSSL.writeString (bio, s))
a95a0107
AC
118
119fun recvQuery bio =
120 case OpenSSL.readInt bio of
121 SOME n =>
122 (case n of
123 0 => Option.map QApt (OpenSSL.readString bio)
d351d679
AC
124 | 1 => Option.map QCron (OpenSSL.readString bio)
125 | 2 => Option.map QFtp (OpenSSL.readString bio)
4d5126e1 126 | 3 => Option.map QTrustedPath (OpenSSL.readString bio)
737c68d4 127 | 4 => Option.map QSocket (OpenSSL.readString bio)
a95a0107
AC
128 | _ => NONE)
129 | NONE => NONE
130
36e42cb8
AC
131fun send (bio, m) =
132 case m of
133 MsgOk => OpenSSL.writeInt (bio, 1)
134 | MsgError s => (OpenSSL.writeInt (bio, 2);
135 OpenSSL.writeString (bio, s))
136 | MsgConfig s => (OpenSSL.writeInt (bio, 3);
137 OpenSSL.writeString (bio, s))
138 | MsgFile {action, domain, dir, file} =>
139 (OpenSSL.writeInt (bio, 4);
140 OpenSSL.writeInt (bio, a2i action);
141 OpenSSL.writeString (bio, domain);
142 OpenSSL.writeString (bio, dir);
143 OpenSSL.writeString (bio, file))
144 | MsgDoFiles => OpenSSL.writeInt (bio, 5)
5ee41dd0
AC
145 | MsgGrant acl => (OpenSSL.writeInt (bio, 6);
146 sendAcl (bio, acl))
411a85f2
AC
147 | MsgRevoke acl => (OpenSSL.writeInt (bio, 7);
148 sendAcl (bio, acl))
08a04eb4
AC
149 | MsgListPerms user => (OpenSSL.writeInt (bio, 8);
150 OpenSSL.writeString (bio, user))
151 | MsgPerms classes => (OpenSSL.writeInt (bio, 9);
c53e82e4
AC
152 sendList (fn (bio, (class, values)) =>
153 (OpenSSL.writeString (bio, class);
154 sendList OpenSSL.writeString (bio, values)))
155 (bio, classes))
094877b1
AC
156 | MsgWhoHas {class, value} => (OpenSSL.writeInt (bio, 10);
157 OpenSSL.writeString (bio, class);
158 OpenSSL.writeString (bio, value))
159 | MsgWhoHasResponse users => (OpenSSL.writeInt (bio, 11);
c53e82e4
AC
160 sendList OpenSSL.writeString (bio, users))
161 | MsgMultiConfig codes => (OpenSSL.writeInt (bio, 12);
162 sendList OpenSSL.writeString (bio, codes))
e69e60cc
AC
163 | MsgRmdom doms => (OpenSSL.writeInt (bio, 13);
164 sendList OpenSSL.writeString (bio, doms))
1824f573 165 | MsgRegenerate => OpenSSL.writeInt (bio, 14)
e69e60cc
AC
166 | MsgRmuser dom => (OpenSSL.writeInt (bio, 15);
167 OpenSSL.writeString (bio, dom))
21d921a5
AC
168 | MsgCreateDbUser {dbtype, passwd} => (OpenSSL.writeInt (bio, 16);
169 OpenSSL.writeString (bio, dbtype);
170 sendOption OpenSSL.writeString (bio, passwd))
90dd48df
AC
171 | MsgCreateDbTable {dbtype, dbname} => (OpenSSL.writeInt (bio, 17);
172 OpenSSL.writeString (bio, dbtype);
173 OpenSSL.writeString (bio, dbname))
08688401
AC
174 | MsgNewMailbox {domain, user, passwd, mailbox} =>
175 (OpenSSL.writeInt (bio, 18);
176 OpenSSL.writeString (bio, domain);
177 OpenSSL.writeString (bio, user);
178 OpenSSL.writeString (bio, passwd);
179 OpenSSL.writeString (bio, mailbox))
180 | MsgPasswdMailbox {domain, user, passwd} =>
181 (OpenSSL.writeInt (bio, 19);
182 OpenSSL.writeString (bio, domain);
183 OpenSSL.writeString (bio, user);
184 OpenSSL.writeString (bio, passwd))
185 | MsgRmMailbox {domain, user} =>
186 (OpenSSL.writeInt (bio, 20);
187 OpenSSL.writeString (bio, domain);
188 OpenSSL.writeString (bio, user))
1d3ef80e
AC
189 | MsgListMailboxes domain =>
190 (OpenSSL.writeInt (bio, 21);
191 OpenSSL.writeString (bio, domain))
192 | MsgMailboxes users =>
193 (OpenSSL.writeInt (bio, 22);
2fc6b0dd
AC
194 sendList (fn (bio, {user, mailbox}) =>
195 (OpenSSL.writeString (bio, user);
196 OpenSSL.writeString (bio, mailbox)))
197 (bio, users))
2e96b9d4
AC
198 | MsgSaQuery addr => (OpenSSL.writeInt (bio, 23);
199 OpenSSL.writeString (bio, addr))
200 | MsgSaStatus b => (OpenSSL.writeInt (bio, 24);
201 sendBool (bio, b))
202 | MsgSaSet (addr, b) => (OpenSSL.writeInt (bio, 25);
203 OpenSSL.writeString (bio, addr);
204 sendBool (bio, b))
2bc5ed22
AC
205 | MsgSmtpLogReq domain => (OpenSSL.writeInt (bio, 26);
206 OpenSSL.writeString (bio, domain))
207 | MsgSmtpLogRes domain => (OpenSSL.writeInt (bio, 27);
208 OpenSSL.writeString (bio, domain))
86aa5de7
AC
209 | MsgDbPasswd {dbtype, passwd} => (OpenSSL.writeInt (bio, 28);
210 OpenSSL.writeString (bio, dbtype);
211 OpenSSL.writeString (bio, passwd))
9f27d58f 212 | MsgShutdown => OpenSSL.writeInt (bio, 29)
75585a67
AC
213 | MsgYes => OpenSSL.writeInt (bio, 30)
214 | MsgNo => OpenSSL.writeInt (bio, 31)
a95a0107
AC
215 | MsgQuery q => (OpenSSL.writeInt (bio, 32);
216 sendQuery (bio, q))
737c68d4
AC
217 | MsgSocket p => (OpenSSL.writeInt (bio, 33);
218 sendSockPerm (bio, p))
36e42cb8
AC
219
220fun checkIt v =
221 case v of
222 NONE => raise OpenSSL.OpenSSL "Bad Msg format"
223 | _ => v
224
225fun recv bio =
226 case OpenSSL.readInt bio of
227 NONE => NONE
228 | SOME n =>
229 checkIt (case n of
230 1 => SOME MsgOk
231 | 2 => Option.map MsgError (OpenSSL.readString bio)
232 | 3 => Option.map MsgConfig (OpenSSL.readString bio)
233 | 4 => (case (OpenSSL.readInt bio,
234 OpenSSL.readString bio,
235 OpenSSL.readString bio,
236 OpenSSL.readString bio) of
237 (SOME action, SOME domain, SOME dir, SOME file) =>
238 SOME (MsgFile {action = i2a action,
239 domain = domain,
240 dir = dir,
241 file = file})
242 | _ => NONE)
243 | 5 => SOME MsgDoFiles
5ee41dd0
AC
244 | 6 => (case recvAcl bio of
245 SOME acl => SOME (MsgGrant acl)
246 | _ => NONE)
411a85f2
AC
247 | 7 => (case recvAcl bio of
248 SOME acl => SOME (MsgRevoke acl)
249 | _ => NONE)
08a04eb4
AC
250 | 8 => (case OpenSSL.readString bio of
251 SOME user => SOME (MsgListPerms user)
252 | _ => NONE)
c53e82e4
AC
253 | 9 => Option.map MsgPerms
254 (recvList (fn bio =>
255 case (OpenSSL.readString bio,
256 recvList OpenSSL.readString bio) of
257 (SOME class, SOME values) => SOME (class, values)
258 | _ => NONE) bio)
094877b1
AC
259 | 10 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
260 (SOME class, SOME value) => SOME (MsgWhoHas {class = class, value = value})
261 | _ => NONE)
c53e82e4
AC
262 | 11 => Option.map MsgWhoHasResponse
263 (recvList OpenSSL.readString bio)
264 | 12 => Option.map MsgMultiConfig
265 (recvList OpenSSL.readString bio)
e69e60cc 266 | 13 => Option.map MsgRmdom (recvList OpenSSL.readString bio)
1824f573 267 | 14 => SOME MsgRegenerate
e69e60cc 268 | 15 => Option.map MsgRmuser (OpenSSL.readString bio)
21d921a5
AC
269 | 16 => (case (OpenSSL.readString bio, recvOption OpenSSL.readString bio) of
270 (SOME dbtype, SOME passwd) =>
271 SOME (MsgCreateDbUser {dbtype = dbtype, passwd = passwd})
272 | _ => NONE)
90dd48df
AC
273 | 17 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
274 (SOME dbtype, SOME dbname) =>
275 SOME (MsgCreateDbTable {dbtype = dbtype, dbname = dbname})
276 | _ => NONE)
08688401
AC
277 | 18 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
278 OpenSSL.readString bio, OpenSSL.readString bio) of
279 (SOME domain, SOME user, SOME passwd, SOME mailbox) =>
280 SOME (MsgNewMailbox {domain = domain, user = user,
281 passwd = passwd, mailbox = mailbox})
282 | _ => NONE)
283 | 19 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
284 OpenSSL.readString bio) of
285 (SOME domain, SOME user, SOME passwd) =>
286 SOME (MsgPasswdMailbox {domain = domain, user = user,
287 passwd = passwd})
288 | _ => NONE)
289 | 20 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
290 (SOME domain, SOME user) =>
291 SOME (MsgRmMailbox {domain = domain, user = user})
292 | _ => NONE)
1d3ef80e 293 | 21 => Option.map MsgListMailboxes (OpenSSL.readString bio)
2fc6b0dd
AC
294 | 22 => Option.map MsgMailboxes (recvList
295 (fn bio =>
296 case (OpenSSL.readString bio,
297 OpenSSL.readString bio) of
298 (SOME user, SOME mailbox) =>
299 SOME {user = user, mailbox = mailbox}
300 | _ => NONE)
301 bio)
2e96b9d4
AC
302 | 23 => Option.map MsgSaQuery (OpenSSL.readString bio)
303 | 24 => Option.map MsgSaStatus (recvBool bio)
304 | 25 => (case (OpenSSL.readString bio, recvBool bio) of
305 (SOME user, SOME b) => SOME (MsgSaSet (user, b))
306 | _ => NONE)
2bc5ed22
AC
307 | 26 => Option.map MsgSmtpLogReq (OpenSSL.readString bio)
308 | 27 => Option.map MsgSmtpLogRes (OpenSSL.readString bio)
86aa5de7
AC
309 | 28 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
310 (SOME dbtype, SOME passwd) =>
311 SOME (MsgDbPasswd {dbtype = dbtype, passwd = passwd})
312 | _ => NONE)
9f27d58f 313 | 29 => SOME MsgShutdown
75585a67
AC
314 | 30 => SOME MsgYes
315 | 31 => SOME MsgNo
a95a0107 316 | 32 => Option.map MsgQuery (recvQuery bio)
737c68d4 317 | 33 => Option.map MsgSocket (recvSockPerm bio)
36e42cb8
AC
318 | _ => NONE)
319
320end