Printing mailbox locations for vmail list
[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 send (bio, m) =
80 case m of
81 MsgOk => OpenSSL.writeInt (bio, 1)
82 | MsgError s => (OpenSSL.writeInt (bio, 2);
83 OpenSSL.writeString (bio, s))
84 | MsgConfig s => (OpenSSL.writeInt (bio, 3);
85 OpenSSL.writeString (bio, s))
86 | MsgFile {action, domain, dir, file} =>
87 (OpenSSL.writeInt (bio, 4);
88 OpenSSL.writeInt (bio, a2i action);
89 OpenSSL.writeString (bio, domain);
90 OpenSSL.writeString (bio, dir);
91 OpenSSL.writeString (bio, file))
92 | MsgDoFiles => OpenSSL.writeInt (bio, 5)
93 | MsgGrant acl => (OpenSSL.writeInt (bio, 6);
94 sendAcl (bio, acl))
95 | MsgRevoke acl => (OpenSSL.writeInt (bio, 7);
96 sendAcl (bio, acl))
97 | MsgListPerms user => (OpenSSL.writeInt (bio, 8);
98 OpenSSL.writeString (bio, user))
99 | MsgPerms classes => (OpenSSL.writeInt (bio, 9);
100 sendList (fn (bio, (class, values)) =>
101 (OpenSSL.writeString (bio, class);
102 sendList OpenSSL.writeString (bio, values)))
103 (bio, classes))
104 | MsgWhoHas {class, value} => (OpenSSL.writeInt (bio, 10);
105 OpenSSL.writeString (bio, class);
106 OpenSSL.writeString (bio, value))
107 | MsgWhoHasResponse users => (OpenSSL.writeInt (bio, 11);
108 sendList OpenSSL.writeString (bio, users))
109 | MsgMultiConfig codes => (OpenSSL.writeInt (bio, 12);
110 sendList OpenSSL.writeString (bio, codes))
111 | MsgRmdom doms => (OpenSSL.writeInt (bio, 13);
112 sendList OpenSSL.writeString (bio, doms))
113 | MsgRegenerate => OpenSSL.writeInt (bio, 14)
114 | MsgRmuser dom => (OpenSSL.writeInt (bio, 15);
115 OpenSSL.writeString (bio, dom))
116 | MsgCreateDbUser {dbtype, passwd} => (OpenSSL.writeInt (bio, 16);
117 OpenSSL.writeString (bio, dbtype);
118 sendOption OpenSSL.writeString (bio, passwd))
119 | MsgCreateDbTable {dbtype, dbname} => (OpenSSL.writeInt (bio, 17);
120 OpenSSL.writeString (bio, dbtype);
121 OpenSSL.writeString (bio, dbname))
122 | MsgNewMailbox {domain, user, passwd, mailbox} =>
123 (OpenSSL.writeInt (bio, 18);
124 OpenSSL.writeString (bio, domain);
125 OpenSSL.writeString (bio, user);
126 OpenSSL.writeString (bio, passwd);
127 OpenSSL.writeString (bio, mailbox))
128 | MsgPasswdMailbox {domain, user, passwd} =>
129 (OpenSSL.writeInt (bio, 19);
130 OpenSSL.writeString (bio, domain);
131 OpenSSL.writeString (bio, user);
132 OpenSSL.writeString (bio, passwd))
133 | MsgRmMailbox {domain, user} =>
134 (OpenSSL.writeInt (bio, 20);
135 OpenSSL.writeString (bio, domain);
136 OpenSSL.writeString (bio, user))
137 | MsgListMailboxes domain =>
138 (OpenSSL.writeInt (bio, 21);
139 OpenSSL.writeString (bio, domain))
140 | MsgMailboxes users =>
141 (OpenSSL.writeInt (bio, 22);
142 sendList (fn (bio, {user, mailbox}) =>
143 (OpenSSL.writeString (bio, user);
144 OpenSSL.writeString (bio, mailbox)))
145 (bio, users))
146
147 fun checkIt v =
148 case v of
149 NONE => raise OpenSSL.OpenSSL "Bad Msg format"
150 | _ => v
151
152 fun recv bio =
153 case OpenSSL.readInt bio of
154 NONE => NONE
155 | SOME n =>
156 checkIt (case n of
157 1 => SOME MsgOk
158 | 2 => Option.map MsgError (OpenSSL.readString bio)
159 | 3 => Option.map MsgConfig (OpenSSL.readString bio)
160 | 4 => (case (OpenSSL.readInt bio,
161 OpenSSL.readString bio,
162 OpenSSL.readString bio,
163 OpenSSL.readString bio) of
164 (SOME action, SOME domain, SOME dir, SOME file) =>
165 SOME (MsgFile {action = i2a action,
166 domain = domain,
167 dir = dir,
168 file = file})
169 | _ => NONE)
170 | 5 => SOME MsgDoFiles
171 | 6 => (case recvAcl bio of
172 SOME acl => SOME (MsgGrant acl)
173 | _ => NONE)
174 | 7 => (case recvAcl bio of
175 SOME acl => SOME (MsgRevoke acl)
176 | _ => NONE)
177 | 8 => (case OpenSSL.readString bio of
178 SOME user => SOME (MsgListPerms user)
179 | _ => NONE)
180 | 9 => Option.map MsgPerms
181 (recvList (fn bio =>
182 case (OpenSSL.readString bio,
183 recvList OpenSSL.readString bio) of
184 (SOME class, SOME values) => SOME (class, values)
185 | _ => NONE) bio)
186 | 10 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
187 (SOME class, SOME value) => SOME (MsgWhoHas {class = class, value = value})
188 | _ => NONE)
189 | 11 => Option.map MsgWhoHasResponse
190 (recvList OpenSSL.readString bio)
191 | 12 => Option.map MsgMultiConfig
192 (recvList OpenSSL.readString bio)
193 | 13 => Option.map MsgRmdom (recvList OpenSSL.readString bio)
194 | 14 => SOME MsgRegenerate
195 | 15 => Option.map MsgRmuser (OpenSSL.readString bio)
196 | 16 => (case (OpenSSL.readString bio, recvOption OpenSSL.readString bio) of
197 (SOME dbtype, SOME passwd) =>
198 SOME (MsgCreateDbUser {dbtype = dbtype, passwd = passwd})
199 | _ => NONE)
200 | 17 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
201 (SOME dbtype, SOME dbname) =>
202 SOME (MsgCreateDbTable {dbtype = dbtype, dbname = dbname})
203 | _ => NONE)
204 | 18 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
205 OpenSSL.readString bio, OpenSSL.readString bio) of
206 (SOME domain, SOME user, SOME passwd, SOME mailbox) =>
207 SOME (MsgNewMailbox {domain = domain, user = user,
208 passwd = passwd, mailbox = mailbox})
209 | _ => NONE)
210 | 19 => (case (OpenSSL.readString bio, OpenSSL.readString bio,
211 OpenSSL.readString bio) of
212 (SOME domain, SOME user, SOME passwd) =>
213 SOME (MsgPasswdMailbox {domain = domain, user = user,
214 passwd = passwd})
215 | _ => NONE)
216 | 20 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
217 (SOME domain, SOME user) =>
218 SOME (MsgRmMailbox {domain = domain, user = user})
219 | _ => NONE)
220 | 21 => Option.map MsgListMailboxes (OpenSSL.readString bio)
221 | 22 => Option.map MsgMailboxes (recvList
222 (fn bio =>
223 case (OpenSSL.readString bio,
224 OpenSSL.readString bio) of
225 (SOME user, SOME mailbox) =>
226 SOME {user = user, mailbox = mailbox}
227 | _ => NONE)
228 bio)
229 | _ => NONE)
230
231 end