1 (* HCoop
Domtool (http
://hcoop
.sourceforge
.net
/)
2 * Copyright (c
) 2006, Adam Chlipala
3 * Copyright (c
) 2011,2014 Clinton Ebadi
<clinton@unknownlamer
.org
>
5 * This program is free software
; you can redistribute it
and/or
6 * modify it under the terms
of the GNU General Public License
7 * as published by the Free Software Foundation
; either version
2
8 * of the License
, or (at your option
) any later version
.
10 * This program is distributed
in the hope that it will be useful
,
11 * but WITHOUT ANY WARRANTY
; without even the implied warranty
of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
. See the
13 * GNU General Public License for more details
.
15 * You should have received a copy
of the GNU General Public License
16 * along
with this program
; if not
, write to the Free Software
17 * Foundation
, Inc
., 51 Franklin Street
, Fifth Floor
, Boston
, MA
02110-1301, USA
.
20 (* Network messages
*)
22 structure Msg
:> MSG
= struct
24 open OpenSSL MsgTypes Slave
35 | _
=> raise OpenSSL
.OpenSSL
"Bad action number to deserialize"
37 fun sendAcl (bio
, {user
, class
, value
}) =
38 (OpenSSL
.writeString (bio
, user
);
39 OpenSSL
.writeString (bio
, class
);
40 OpenSSL
.writeString (bio
, value
))
43 case (OpenSSL
.readString bio
, OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
44 (SOME user
, SOME class
, SOME value
) => SOME
{user
= user
, class
= class
, value
= value
}
47 fun sendList
f (bio
, ls
) =
49 (OpenSSL
.writeInt (bio
, 1);
51 OpenSSL
.writeInt (bio
, 0))
56 case OpenSSL
.readInt bio
of
57 SOME
0 => SOME (rev ls
)
60 SOME x
=> loop (x
:: ls
)
67 fun sendOption
f (bio
, opt
) =
69 NONE
=> OpenSSL
.writeInt (bio
, 0)
70 | SOME x
=> (OpenSSL
.writeInt (bio
, 1);
73 fun recvOption f bio
=
74 case OpenSSL
.readInt bio
of
78 SOME x
=> SOME (SOME x
)
82 fun sendBool (bio
, b
) =
84 OpenSSL
.writeInt (bio
, 1)
86 OpenSSL
.writeInt (bio
, 0)
89 case OpenSSL
.readInt bio
of
94 fun sendSockPerm (bio
, p
) =
96 Any
=> OpenSSL
.writeInt (bio
, 0)
97 | Client
=> OpenSSL
.writeInt (bio
, 1)
98 | Server
=> OpenSSL
.writeInt (bio
, 2)
99 | Nada
=> OpenSSL
.writeInt (bio
, 3)
101 fun recvSockPerm bio
=
102 case OpenSSL
.readInt bio
of
104 | SOME
1 => SOME Client
105 | SOME
2 => SOME Server
106 | SOME
3 => SOME Nada
109 fun sendQuery (bio
, q
) =
111 QApt s
=> (OpenSSL
.writeInt (bio
, 0);
112 OpenSSL
.writeString (bio
, s
))
113 | QCron s
=> (OpenSSL
.writeInt (bio
, 1);
114 OpenSSL
.writeString (bio
, s
))
115 | QFtp s
=> (OpenSSL
.writeInt (bio
, 2);
116 OpenSSL
.writeString (bio
, s
))
117 | QTrustedPath s
=> (OpenSSL
.writeInt (bio
, 3);
118 OpenSSL
.writeString (bio
, s
))
119 | QSocket s
=> (OpenSSL
.writeInt (bio
, 4);
120 OpenSSL
.writeString (bio
, s
))
121 | QFirewall
{node
, user
} => (OpenSSL
.writeInt (bio
, 5);
122 OpenSSL
.writeString (bio
, node
);
123 OpenSSL
.writeString (bio
, user
))
124 | QAptExists s
=> (OpenSSL
.writeInt (bio
, 6);
125 OpenSSL
.writeString (bio
, s
))
128 case OpenSSL
.readInt bio
of
131 0 => Option
.map
QApt (OpenSSL
.readString bio
)
132 |
1 => Option
.map
QCron (OpenSSL
.readString bio
)
133 |
2 => Option
.map
QFtp (OpenSSL
.readString bio
)
134 |
3 => Option
.map
QTrustedPath (OpenSSL
.readString bio
)
135 |
4 => Option
.map
QSocket (OpenSSL
.readString bio
)
136 |
5 => (case ((OpenSSL
.readString bio
), (OpenSSL
.readString bio
)) of
137 (SOME node
, SOME user
) => SOME (QFirewall
{ node
= node
, user
= user
})
139 |
6 => Option
.map
QAptExists (OpenSSL
.readString bio
)
145 MsgOk
=> OpenSSL
.writeInt (bio
, 1)
146 | MsgError s
=> (OpenSSL
.writeInt (bio
, 2);
147 OpenSSL
.writeString (bio
, s
))
148 | MsgConfig s
=> (OpenSSL
.writeInt (bio
, 3);
149 OpenSSL
.writeString (bio
, s
))
150 | MsgFile
{action
, domain
, dir
, file
} =>
151 (OpenSSL
.writeInt (bio
, 4);
152 OpenSSL
.writeInt (bio
, a2i action
);
153 OpenSSL
.writeString (bio
, domain
);
154 OpenSSL
.writeString (bio
, dir
);
155 OpenSSL
.writeString (bio
, file
))
156 | MsgDoFiles
=> OpenSSL
.writeInt (bio
, 5)
157 | MsgGrant acl
=> (OpenSSL
.writeInt (bio
, 6);
159 | MsgRevoke acl
=> (OpenSSL
.writeInt (bio
, 7);
161 | MsgListPerms user
=> (OpenSSL
.writeInt (bio
, 8);
162 OpenSSL
.writeString (bio
, user
))
163 | MsgPerms classes
=> (OpenSSL
.writeInt (bio
, 9);
164 sendList (fn (bio
, (class
, values
)) =>
165 (OpenSSL
.writeString (bio
, class
);
166 sendList OpenSSL
.writeString (bio
, values
)))
168 | MsgWhoHas
{class
, value
} => (OpenSSL
.writeInt (bio
, 10);
169 OpenSSL
.writeString (bio
, class
);
170 OpenSSL
.writeString (bio
, value
))
171 | MsgWhoHasResponse users
=> (OpenSSL
.writeInt (bio
, 11);
172 sendList OpenSSL
.writeString (bio
, users
))
173 | MsgMultiConfig codes
=> (OpenSSL
.writeInt (bio
, 12);
174 sendList OpenSSL
.writeString (bio
, codes
))
175 | MsgRmdom doms
=> (OpenSSL
.writeInt (bio
, 13);
176 sendList OpenSSL
.writeString (bio
, doms
))
177 | MsgRegenerate
=> OpenSSL
.writeInt (bio
, 14)
178 | MsgRmuser dom
=> (OpenSSL
.writeInt (bio
, 15);
179 OpenSSL
.writeString (bio
, dom
))
180 | MsgCreateDbUser
{dbtype
, passwd
} => (OpenSSL
.writeInt (bio
, 16);
181 OpenSSL
.writeString (bio
, dbtype
);
182 sendOption OpenSSL
.writeString (bio
, passwd
))
183 | MsgCreateDb
{dbtype
, dbname
, encoding
} => (OpenSSL
.writeInt (bio
, 17);
184 OpenSSL
.writeString (bio
, dbtype
);
185 OpenSSL
.writeString (bio
, dbname
);
186 sendOption OpenSSL
.writeString (bio
, encoding
))
187 | MsgNewMailbox
{domain
, user
, passwd
, mailbox
} =>
188 (OpenSSL
.writeInt (bio
, 18);
189 OpenSSL
.writeString (bio
, domain
);
190 OpenSSL
.writeString (bio
, user
);
191 OpenSSL
.writeString (bio
, passwd
);
192 OpenSSL
.writeString (bio
, mailbox
))
193 | MsgPasswdMailbox
{domain
, user
, passwd
} =>
194 (OpenSSL
.writeInt (bio
, 19);
195 OpenSSL
.writeString (bio
, domain
);
196 OpenSSL
.writeString (bio
, user
);
197 OpenSSL
.writeString (bio
, passwd
))
198 | MsgRmMailbox
{domain
, user
} =>
199 (OpenSSL
.writeInt (bio
, 20);
200 OpenSSL
.writeString (bio
, domain
);
201 OpenSSL
.writeString (bio
, user
))
202 | MsgListMailboxes domain
=>
203 (OpenSSL
.writeInt (bio
, 21);
204 OpenSSL
.writeString (bio
, domain
))
205 | MsgMailboxes users
=>
206 (OpenSSL
.writeInt (bio
, 22);
207 sendList (fn (bio
, {user
, mailbox
}) =>
208 (OpenSSL
.writeString (bio
, user
);
209 OpenSSL
.writeString (bio
, mailbox
)))
211 | MsgSaQuery addr
=> (OpenSSL
.writeInt (bio
, 23);
212 OpenSSL
.writeString (bio
, addr
))
213 | MsgSaStatus b
=> (OpenSSL
.writeInt (bio
, 24);
215 |
MsgSaSet (addr
, b
) => (OpenSSL
.writeInt (bio
, 25);
216 OpenSSL
.writeString (bio
, addr
);
218 | MsgSmtpLogReq domain
=> (OpenSSL
.writeInt (bio
, 26);
219 OpenSSL
.writeString (bio
, domain
))
220 | MsgSmtpLogRes domain
=> (OpenSSL
.writeInt (bio
, 27);
221 OpenSSL
.writeString (bio
, domain
))
222 | MsgDbPasswd
{dbtype
, passwd
} => (OpenSSL
.writeInt (bio
, 28);
223 OpenSSL
.writeString (bio
, dbtype
);
224 OpenSSL
.writeString (bio
, passwd
))
225 | MsgShutdown
=> OpenSSL
.writeInt (bio
, 29)
226 | MsgYes
=> OpenSSL
.writeInt (bio
, 30)
227 | MsgNo
=> OpenSSL
.writeInt (bio
, 31)
228 | MsgQuery q
=> (OpenSSL
.writeInt (bio
, 32);
230 | MsgSocket p
=> (OpenSSL
.writeInt (bio
, 33);
231 sendSockPerm (bio
, p
))
232 | MsgFirewall ls
=> (OpenSSL
.writeInt (bio
, 34);
233 sendList OpenSSL
.writeString (bio
, ls
))
234 | MsgRegenerateTc
=> OpenSSL
.writeInt (bio
, 35)
235 | MsgDropDb
{dbtype
, dbname
} => (OpenSSL
.writeInt (bio
, 36);
236 OpenSSL
.writeString (bio
, dbtype
);
237 OpenSSL
.writeString (bio
, dbname
))
238 | MsgGrantDb
{dbtype
, dbname
} => (OpenSSL
.writeInt (bio
, 37);
239 OpenSSL
.writeString (bio
, dbtype
);
240 OpenSSL
.writeString (bio
, dbname
))
241 | MsgMysqlFixperms
=> OpenSSL
.writeInt (bio
, 38)
242 | MsgDescribe dom
=> (OpenSSL
.writeInt (bio
, 39);
243 OpenSSL
.writeString (bio
, dom
))
244 | MsgDescription s
=> (OpenSSL
.writeInt (bio
, 40);
245 OpenSSL
.writeString (bio
, s
))
246 | MsgReUsers
=> OpenSSL
.writeInt (bio
, 41)
247 | MsgVmailChanged
=> OpenSSL
.writeInt (bio
, 42)
248 | MsgFirewallRegen
=> OpenSSL
.writeInt (bio
, 43)
249 | MsgAptQuery
{section
, description
} => (OpenSSL
.writeInt (bio
, 44);
250 OpenSSL
.writeString (bio
, section
);
251 OpenSSL
.writeString (bio
, description
))
252 | MsgSaChanged
=> OpenSSL
.writeInt (bio
, 45)
253 | MsgPortalPasswdMailbox
{domain
: string, user
: string, oldpasswd
: string, newpasswd
: string} =>
254 (OpenSSL
.writeInt (bio
, 46);
255 OpenSSL
.writeString (bio
, domain
);
256 OpenSSL
.writeString (bio
, user
);
257 OpenSSL
.writeString (bio
, oldpasswd
);
258 OpenSSL
.writeString (bio
, newpasswd
))
262 NONE
=> raise OpenSSL
.OpenSSL
"Bad Msg format"
266 case OpenSSL
.readInt bio
of
271 |
2 => Option
.map
MsgError (OpenSSL
.readString bio
)
272 |
3 => Option
.map
MsgConfig (OpenSSL
.readString bio
)
273 |
4 => (case (OpenSSL
.readInt bio
,
274 OpenSSL
.readString bio
,
275 OpenSSL
.readString bio
,
276 OpenSSL
.readString bio
) of
277 (SOME action
, SOME domain
, SOME dir
, SOME file
) =>
278 SOME (MsgFile
{action
= i2a action
,
283 |
5 => SOME MsgDoFiles
284 |
6 => (case recvAcl bio
of
285 SOME acl
=> SOME (MsgGrant acl
)
287 |
7 => (case recvAcl bio
of
288 SOME acl
=> SOME (MsgRevoke acl
)
290 |
8 => (case OpenSSL
.readString bio
of
291 SOME user
=> SOME (MsgListPerms user
)
293 |
9 => Option
.map MsgPerms
295 case (OpenSSL
.readString bio
,
296 recvList OpenSSL
.readString bio
) of
297 (SOME class
, SOME values
) => SOME (class
, values
)
299 |
10 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
300 (SOME class
, SOME value
) => SOME (MsgWhoHas
{class
= class
, value
= value
})
302 |
11 => Option
.map MsgWhoHasResponse
303 (recvList OpenSSL
.readString bio
)
304 |
12 => Option
.map MsgMultiConfig
305 (recvList OpenSSL
.readString bio
)
306 |
13 => Option
.map
MsgRmdom (recvList OpenSSL
.readString bio
)
307 |
14 => SOME MsgRegenerate
308 |
15 => Option
.map
MsgRmuser (OpenSSL
.readString bio
)
309 |
16 => (case (OpenSSL
.readString bio
, recvOption OpenSSL
.readString bio
) of
310 (SOME dbtype
, SOME passwd
) =>
311 SOME (MsgCreateDbUser
{dbtype
= dbtype
, passwd
= passwd
})
313 |
17 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
, recvOption OpenSSL
.readString bio
) of
314 (SOME dbtype
, SOME dbname
, SOME encoding
) =>
315 SOME (MsgCreateDb
{dbtype
= dbtype
, dbname
= dbname
, encoding
= encoding
})
317 |
18 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
,
318 OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
319 (SOME domain
, SOME user
, SOME passwd
, SOME mailbox
) =>
320 SOME (MsgNewMailbox
{domain
= domain
, user
= user
,
321 passwd
= passwd
, mailbox
= mailbox
})
323 |
19 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
,
324 OpenSSL
.readString bio
) of
325 (SOME domain
, SOME user
, SOME passwd
) =>
326 SOME (MsgPasswdMailbox
{domain
= domain
, user
= user
,
329 |
20 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
330 (SOME domain
, SOME user
) =>
331 SOME (MsgRmMailbox
{domain
= domain
, user
= user
})
333 |
21 => Option
.map
MsgListMailboxes (OpenSSL
.readString bio
)
334 |
22 => Option
.map
MsgMailboxes (recvList
336 case (OpenSSL
.readString bio
,
337 OpenSSL
.readString bio
) of
338 (SOME user
, SOME mailbox
) =>
339 SOME
{user
= user
, mailbox
= mailbox
}
342 |
23 => Option
.map
MsgSaQuery (OpenSSL
.readString bio
)
343 |
24 => Option
.map
MsgSaStatus (recvBool bio
)
344 |
25 => (case (OpenSSL
.readString bio
, recvBool bio
) of
345 (SOME user
, SOME b
) => SOME (MsgSaSet (user
, b
))
347 |
26 => Option
.map
MsgSmtpLogReq (OpenSSL
.readString bio
)
348 |
27 => Option
.map
MsgSmtpLogRes (OpenSSL
.readString bio
)
349 |
28 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
350 (SOME dbtype
, SOME passwd
) =>
351 SOME (MsgDbPasswd
{dbtype
= dbtype
, passwd
= passwd
})
353 |
29 => SOME MsgShutdown
356 |
32 => Option
.map
MsgQuery (recvQuery bio
)
357 |
33 => Option
.map
MsgSocket (recvSockPerm bio
)
358 |
34 => Option
.map
MsgFirewall (recvList OpenSSL
.readString bio
)
359 |
35 => SOME MsgRegenerateTc
360 |
36 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
361 (SOME dbtype
, SOME dbname
) =>
362 SOME (MsgDropDb
{dbtype
= dbtype
, dbname
= dbname
})
364 |
37 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
365 (SOME dbtype
, SOME dbname
) =>
366 SOME (MsgGrantDb
{dbtype
= dbtype
, dbname
= dbname
})
368 |
38 => SOME MsgMysqlFixperms
369 |
39 => Option
.map
MsgDescribe (OpenSSL
.readString bio
)
370 |
40 => Option
.map
MsgDescription (OpenSSL
.readString bio
)
371 |
41 => SOME MsgReUsers
372 |
42 => SOME MsgVmailChanged
373 |
43 => SOME MsgFirewallRegen
374 |
44 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
375 (SOME section
, SOME description
) => SOME (MsgAptQuery
{section
= section
, description
= description
})
377 |
45 => SOME MsgSaChanged
378 |
46 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
, OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
379 (SOME domain
, SOME user
, SOME oldpasswd
, SOME newpasswd
) =>
380 SOME (MsgPortalPasswdMailbox
{domain
= domain
, user
= user
, oldpasswd
= oldpasswd
, newpasswd
= newpasswd
})