1 (* HCoop
Domtool (http
://hcoop
.sourceforge
.net
/)
2 * Copyright (c
) 2006, Adam Chlipala
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
.
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
.
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
.
19 (* Network messages
*)
21 structure Msg
:> MSG
= struct
23 open OpenSSL MsgTypes Slave
32 | _
=> raise OpenSSL
.OpenSSL
"Bad action number to deserialize"
34 fun sendAcl (bio
, {user
, class
, value
}) =
35 (OpenSSL
.writeString (bio
, user
);
36 OpenSSL
.writeString (bio
, class
);
37 OpenSSL
.writeString (bio
, value
))
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
}
44 fun sendList
f (bio
, ls
) =
46 (OpenSSL
.writeInt (bio
, 1);
48 OpenSSL
.writeInt (bio
, 0))
53 case OpenSSL
.readInt bio
of
54 SOME
0 => SOME (rev ls
)
57 SOME x
=> loop (x
:: ls
)
64 fun sendOption
f (bio
, opt
) =
66 NONE
=> OpenSSL
.writeInt (bio
, 0)
67 | SOME x
=> (OpenSSL
.writeInt (bio
, 1);
70 fun recvOption f bio
=
71 case OpenSSL
.readInt bio
of
75 SOME x
=> SOME (SOME x
)
79 fun sendBool (bio
, b
) =
81 OpenSSL
.writeInt (bio
, 1)
83 OpenSSL
.writeInt (bio
, 0)
86 case OpenSSL
.readInt bio
of
91 fun sendSockPerm (bio
, p
) =
93 Any
=> OpenSSL
.writeInt (bio
, 0)
94 | Client
=> OpenSSL
.writeInt (bio
, 1)
95 | Server
=> OpenSSL
.writeInt (bio
, 2)
96 | Nada
=> OpenSSL
.writeInt (bio
, 3)
98 fun recvSockPerm bio
=
99 case OpenSSL
.readInt bio
of
101 | SOME
1 => SOME Client
102 | SOME
2 => SOME Server
103 | SOME
3 => SOME Nada
106 fun sendQuery (bio
, q
) =
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
))
120 case OpenSSL
.readInt bio
of
123 0 => Option
.map
QApt (OpenSSL
.readString bio
)
124 |
1 => Option
.map
QCron (OpenSSL
.readString bio
)
125 |
2 => Option
.map
QFtp (OpenSSL
.readString bio
)
126 |
3 => Option
.map
QTrustedPath (OpenSSL
.readString bio
)
127 |
4 => Option
.map
QSocket (OpenSSL
.readString bio
)
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)
145 | MsgGrant acl
=> (OpenSSL
.writeInt (bio
, 6);
147 | MsgRevoke acl
=> (OpenSSL
.writeInt (bio
, 7);
149 | MsgListPerms user
=> (OpenSSL
.writeInt (bio
, 8);
150 OpenSSL
.writeString (bio
, user
))
151 | MsgPerms classes
=> (OpenSSL
.writeInt (bio
, 9);
152 sendList (fn (bio
, (class
, values
)) =>
153 (OpenSSL
.writeString (bio
, class
);
154 sendList OpenSSL
.writeString (bio
, values
)))
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);
160 sendList OpenSSL
.writeString (bio
, users
))
161 | MsgMultiConfig codes
=> (OpenSSL
.writeInt (bio
, 12);
162 sendList OpenSSL
.writeString (bio
, codes
))
163 | MsgRmdom doms
=> (OpenSSL
.writeInt (bio
, 13);
164 sendList OpenSSL
.writeString (bio
, doms
))
165 | MsgRegenerate
=> OpenSSL
.writeInt (bio
, 14)
166 | MsgRmuser dom
=> (OpenSSL
.writeInt (bio
, 15);
167 OpenSSL
.writeString (bio
, dom
))
168 | MsgCreateDbUser
{dbtype
, passwd
} => (OpenSSL
.writeInt (bio
, 16);
169 OpenSSL
.writeString (bio
, dbtype
);
170 sendOption OpenSSL
.writeString (bio
, passwd
))
171 | MsgCreateDbTable
{dbtype
, dbname
} => (OpenSSL
.writeInt (bio
, 17);
172 OpenSSL
.writeString (bio
, dbtype
);
173 OpenSSL
.writeString (bio
, dbname
))
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
))
189 | MsgListMailboxes domain
=>
190 (OpenSSL
.writeInt (bio
, 21);
191 OpenSSL
.writeString (bio
, domain
))
192 | MsgMailboxes users
=>
193 (OpenSSL
.writeInt (bio
, 22);
194 sendList (fn (bio
, {user
, mailbox
}) =>
195 (OpenSSL
.writeString (bio
, user
);
196 OpenSSL
.writeString (bio
, mailbox
)))
198 | MsgSaQuery addr
=> (OpenSSL
.writeInt (bio
, 23);
199 OpenSSL
.writeString (bio
, addr
))
200 | MsgSaStatus b
=> (OpenSSL
.writeInt (bio
, 24);
202 |
MsgSaSet (addr
, b
) => (OpenSSL
.writeInt (bio
, 25);
203 OpenSSL
.writeString (bio
, addr
);
205 | MsgSmtpLogReq domain
=> (OpenSSL
.writeInt (bio
, 26);
206 OpenSSL
.writeString (bio
, domain
))
207 | MsgSmtpLogRes domain
=> (OpenSSL
.writeInt (bio
, 27);
208 OpenSSL
.writeString (bio
, domain
))
209 | MsgDbPasswd
{dbtype
, passwd
} => (OpenSSL
.writeInt (bio
, 28);
210 OpenSSL
.writeString (bio
, dbtype
);
211 OpenSSL
.writeString (bio
, passwd
))
212 | MsgShutdown
=> OpenSSL
.writeInt (bio
, 29)
213 | MsgYes
=> OpenSSL
.writeInt (bio
, 30)
214 | MsgNo
=> OpenSSL
.writeInt (bio
, 31)
215 | MsgQuery q
=> (OpenSSL
.writeInt (bio
, 32);
217 | MsgSocket p
=> (OpenSSL
.writeInt (bio
, 33);
218 sendSockPerm (bio
, p
))
222 NONE
=> raise OpenSSL
.OpenSSL
"Bad Msg format"
226 case OpenSSL
.readInt bio
of
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
,
243 |
5 => SOME MsgDoFiles
244 |
6 => (case recvAcl bio
of
245 SOME acl
=> SOME (MsgGrant acl
)
247 |
7 => (case recvAcl bio
of
248 SOME acl
=> SOME (MsgRevoke acl
)
250 |
8 => (case OpenSSL
.readString bio
of
251 SOME user
=> SOME (MsgListPerms user
)
253 |
9 => Option
.map MsgPerms
255 case (OpenSSL
.readString bio
,
256 recvList OpenSSL
.readString bio
) of
257 (SOME class
, SOME values
) => SOME (class
, values
)
259 |
10 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
260 (SOME class
, SOME value
) => SOME (MsgWhoHas
{class
= class
, value
= value
})
262 |
11 => Option
.map MsgWhoHasResponse
263 (recvList OpenSSL
.readString bio
)
264 |
12 => Option
.map MsgMultiConfig
265 (recvList OpenSSL
.readString bio
)
266 |
13 => Option
.map
MsgRmdom (recvList OpenSSL
.readString bio
)
267 |
14 => SOME MsgRegenerate
268 |
15 => Option
.map
MsgRmuser (OpenSSL
.readString bio
)
269 |
16 => (case (OpenSSL
.readString bio
, recvOption OpenSSL
.readString bio
) of
270 (SOME dbtype
, SOME passwd
) =>
271 SOME (MsgCreateDbUser
{dbtype
= dbtype
, passwd
= passwd
})
273 |
17 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
274 (SOME dbtype
, SOME dbname
) =>
275 SOME (MsgCreateDbTable
{dbtype
= dbtype
, dbname
= dbname
})
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
})
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
,
289 |
20 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
290 (SOME domain
, SOME user
) =>
291 SOME (MsgRmMailbox
{domain
= domain
, user
= user
})
293 |
21 => Option
.map
MsgListMailboxes (OpenSSL
.readString bio
)
294 |
22 => Option
.map
MsgMailboxes (recvList
296 case (OpenSSL
.readString bio
,
297 OpenSSL
.readString bio
) of
298 (SOME user
, SOME mailbox
) =>
299 SOME
{user
= user
, mailbox
= mailbox
}
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
))
307 |
26 => Option
.map
MsgSmtpLogReq (OpenSSL
.readString bio
)
308 |
27 => Option
.map
MsgSmtpLogRes (OpenSSL
.readString bio
)
309 |
28 => (case (OpenSSL
.readString bio
, OpenSSL
.readString bio
) of
310 (SOME dbtype
, SOME passwd
) =>
311 SOME (MsgDbPasswd
{dbtype
= dbtype
, passwd
= passwd
})
313 |
29 => SOME MsgShutdown
316 |
32 => Option
.map
MsgQuery (recvQuery bio
)
317 |
33 => Option
.map
MsgSocket (recvSockPerm bio
)