Printing mailbox locations for vmail list
[hcoop/domtool2.git] / src / main.sml
CommitLineData
234b917a
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.
dac62e84 17 *)
234b917a
AC
18
19(* Main interface *)
20
21structure Main :> MAIN = struct
22
36e42cb8 23open Ast MsgTypes Print
234b917a 24
6ae327f8
AC
25structure SM = StringMap
26
aa56e112 27fun init () = Acl.read Config.aclFile
234b917a 28
d189ec0e 29fun check' G fname =
a3698041
AC
30 let
31 val prog = Parse.parse fname
32 in
33 if !ErrorMsg.anyErrors then
d189ec0e 34 G
a3698041 35 else
aa56e112 36 Tycheck.checkFile G (Defaults.tInit ()) prog
a3698041
AC
37 end
38
d189ec0e 39fun basis () =
234b917a 40 let
d189ec0e
AC
41 val dir = Posix.FileSys.opendir Config.libRoot
42
43 fun loop files =
44 case Posix.FileSys.readdir dir of
d612d62c
AC
45 NONE => (Posix.FileSys.closedir dir;
46 files)
d189ec0e
AC
47 | SOME fname =>
48 if String.isSuffix ".dtl" fname then
d612d62c
AC
49 loop (OS.Path.joinDirFile {dir = Config.libRoot,
50 file = fname}
d189ec0e
AC
51 :: files)
52 else
53 loop files
54
55 val files = loop []
c53e82e4 56 val (_, files) = Order.order NONE files
d189ec0e 57 in
6ae327f8
AC
58 if !ErrorMsg.anyErrors then
59 Env.empty
60 else
b3159a70
AC
61 (Tycheck.allowExterns ();
62 foldl (fn (fname, G) => check' G fname) Env.empty files
63 before Tycheck.disallowExterns ())
d189ec0e
AC
64 end
65
66fun check fname =
67 let
68 val _ = ErrorMsg.reset ()
12adf55a 69 val _ = Env.preTycheck ()
d189ec0e
AC
70
71 val b = basis ()
234b917a
AC
72 in
73 if !ErrorMsg.anyErrors then
36e42cb8 74 raise ErrorMsg.Error
234b917a
AC
75 else
76 let
b3159a70 77 val _ = Tycheck.disallowExterns ()
7f012ffd 78 val _ = ErrorMsg.reset ()
d189ec0e 79 val prog = Parse.parse fname
234b917a 80 in
492c1cff 81 if !ErrorMsg.anyErrors then
36e42cb8 82 raise ErrorMsg.Error
492c1cff 83 else
d189ec0e 84 let
aa56e112 85 val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
d189ec0e 86 in
36e42cb8
AC
87 if !ErrorMsg.anyErrors then
88 raise ErrorMsg.Error
89 else
90 (G', #3 prog)
d189ec0e 91 end
234b917a
AC
92 end
93 end
94
c53e82e4
AC
95val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-")
96
97fun checkDir dname =
98 let
99 val b = basis ()
100
101 val dir = Posix.FileSys.opendir dname
102
103 fun loop files =
104 case Posix.FileSys.readdir dir of
105 NONE => (Posix.FileSys.closedir dir;
106 files)
107 | SOME fname =>
108 if notTmp fname then
109 loop (OS.Path.joinDirFile {dir = dname,
110 file = fname}
111 :: files)
112 else
113 loop files
114
115 val files = loop []
116 val (_, files) = Order.order (SOME b) files
117 in
118 if !ErrorMsg.anyErrors then
1824f573 119 raise ErrorMsg.Error
c53e82e4
AC
120 else
121 (foldl (fn (fname, G) => check' G fname) b files;
1824f573
AC
122 if !ErrorMsg.anyErrors then
123 raise ErrorMsg.Error
124 else
125 ())
c53e82e4
AC
126 end
127
d189ec0e 128fun reduce fname =
a3698041 129 let
d189ec0e 130 val (G, body) = check fname
a3698041
AC
131 in
132 if !ErrorMsg.anyErrors then
d189ec0e 133 NONE
a3698041 134 else
d189ec0e
AC
135 case body of
136 SOME body =>
137 let
138 val body' = Reduce.reduceExp G body
139 in
140 (*printd (PD.hovBox (PD.PPS.Rel 0,
141 [PD.string "Result:",
142 PD.space 1,
143 p_exp body']))*)
144 SOME body'
145 end
146 | _ => NONE
a3698041
AC
147 end
148
d189ec0e
AC
149fun eval fname =
150 case reduce fname of
151 (SOME body') =>
152 if !ErrorMsg.anyErrors then
36e42cb8 153 raise ErrorMsg.Error
d189ec0e 154 else
aa56e112 155 Eval.exec (Defaults.eInit ()) body'
36e42cb8 156 | NONE => raise ErrorMsg.Error
d189ec0e 157
1824f573
AC
158fun eval' fname =
159 case reduce fname of
160 (SOME body') =>
161 if !ErrorMsg.anyErrors then
162 raise ErrorMsg.Error
163 else
164 ignore (Eval.exec' (Defaults.eInit ()) body')
165 | NONE => raise ErrorMsg.Error
166
3b267643
AC
167val dispatcher =
168 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
559e89e9 169
5ee41dd0 170fun requestContext f =
07cc384c 171 let
a56cc2c3
AC
172 val uid = Posix.ProcEnv.getuid ()
173 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
5ee41dd0 174
a56cc2c3
AC
175 val () = Acl.read Config.aclFile
176 val () = Domain.setUser user
5ee41dd0
AC
177
178 val () = f ()
aa56e112 179
aa56e112 180 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
a088cea6 181 Config.keyDir ^ "/" ^ user ^ "/key.pem",
3b267643 182 Config.trustStore)
5ee41dd0
AC
183 in
184 (user, context)
185 end
07cc384c 186
5ee41dd0
AC
187fun requestBio f =
188 let
189 val (user, context) = requestContext f
190 in
191 (user, OpenSSL.connect (context, dispatcher))
192 end
193
194fun request fname =
195 let
196 val (user, bio) = requestBio (fn () => ignore (check fname))
559e89e9 197
3b267643
AC
198 val inf = TextIO.openIn fname
199
36e42cb8 200 fun loop lines =
3b267643 201 case TextIO.inputLine inf of
36e42cb8
AC
202 NONE => String.concat (List.rev lines)
203 | SOME line => loop (line :: lines)
204
205 val code = loop []
559e89e9 206 in
3b267643 207 TextIO.closeIn inf;
36e42cb8
AC
208 Msg.send (bio, MsgConfig code);
209 case Msg.recv bio of
210 NONE => print "Server closed connection unexpectedly.\n"
211 | SOME m =>
212 case m of
213 MsgOk => print "Configuration succeeded.\n"
214 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
215 | _ => print "Unexpected server reply.\n";
3b267643 216 OpenSSL.close bio
559e89e9 217 end
aa56e112 218 handle ErrorMsg.Error => ()
559e89e9 219
c53e82e4
AC
220fun requestDir dname =
221 let
1824f573
AC
222 val _ = ErrorMsg.reset ()
223
224 val (user, bio) = requestBio (fn () => checkDir dname)
c53e82e4
AC
225
226 val b = basis ()
227
228 val dir = Posix.FileSys.opendir dname
229
230 fun loop files =
231 case Posix.FileSys.readdir dir of
232 NONE => (Posix.FileSys.closedir dir;
233 files)
234 | SOME fname =>
235 if notTmp fname then
236 loop (OS.Path.joinDirFile {dir = dname,
237 file = fname}
238 :: files)
239 else
240 loop files
241
242 val files = loop []
243 val (_, files) = Order.order (SOME b) files
244
245 val _ = if !ErrorMsg.anyErrors then
246 raise ErrorMsg.Error
247 else
248 ()
249
250 val codes = map (fn fname =>
251 let
252 val inf = TextIO.openIn fname
253
254 fun loop lines =
255 case TextIO.inputLine inf of
256 NONE => String.concat (rev lines)
257 | SOME line => loop (line :: lines)
258 in
259 loop []
260 before TextIO.closeIn inf
261 end) files
262 in
1824f573
AC
263 if !ErrorMsg.anyErrors then
264 ()
265 else
266 (Msg.send (bio, MsgMultiConfig codes);
267 case Msg.recv bio of
268 NONE => print "Server closed connection unexpectedly.\n"
269 | SOME m =>
270 case m of
271 MsgOk => print "Configuration succeeded.\n"
272 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
273 | _ => print "Unexpected server reply.\n";
274 OpenSSL.close bio)
c53e82e4
AC
275 end
276 handle ErrorMsg.Error => ()
277
5ee41dd0
AC
278fun requestGrant acl =
279 let
280 val (user, bio) = requestBio (fn () => ())
281 in
282 Msg.send (bio, MsgGrant acl);
283 case Msg.recv bio of
284 NONE => print "Server closed connection unexpectedly.\n"
285 | SOME m =>
286 case m of
287 MsgOk => print "Grant succeeded.\n"
288 | MsgError s => print ("Grant failed: " ^ s ^ "\n")
289 | _ => print "Unexpected server reply.\n";
290 OpenSSL.close bio
291 end
292
411a85f2
AC
293fun requestRevoke acl =
294 let
295 val (user, bio) = requestBio (fn () => ())
296 in
297 Msg.send (bio, MsgRevoke acl);
298 case Msg.recv bio of
299 NONE => print "Server closed connection unexpectedly.\n"
300 | SOME m =>
301 case m of
302 MsgOk => print "Revoke succeeded.\n"
303 | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
304 | _ => print "Unexpected server reply.\n";
305 OpenSSL.close bio
306 end
307
08a04eb4
AC
308fun requestListPerms user =
309 let
310 val (_, bio) = requestBio (fn () => ())
311 in
312 Msg.send (bio, MsgListPerms user);
313 (case Msg.recv bio of
314 NONE => (print "Server closed connection unexpectedly.\n";
315 NONE)
316 | SOME m =>
317 case m of
318 MsgPerms perms => SOME perms
319 | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
320 NONE)
321 | _ => (print "Unexpected server reply.\n";
322 NONE))
323 before OpenSSL.close bio
324 end
325
094877b1
AC
326fun requestWhoHas perm =
327 let
328 val (_, bio) = requestBio (fn () => ())
329 in
330 Msg.send (bio, MsgWhoHas perm);
331 (case Msg.recv bio of
332 NONE => (print "Server closed connection unexpectedly.\n";
333 NONE)
334 | SOME m =>
335 case m of
336 MsgWhoHasResponse users => SOME users
337 | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
338 NONE)
339 | _ => (print "Unexpected server reply.\n";
340 NONE))
341 before OpenSSL.close bio
342 end
343
1824f573
AC
344fun requestRegen () =
345 let
346 val (_, bio) = requestBio (fn () => ())
347 in
348 Msg.send (bio, MsgRegenerate);
349 case Msg.recv bio of
350 NONE => print "Server closed connection unexpectedly.\n"
351 | SOME m =>
352 case m of
353 MsgOk => print "Regeneration succeeded.\n"
354 | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
355 | _ => print "Unexpected server reply.\n";
356 OpenSSL.close bio
357 end
358
c189cbe9
AC
359fun requestRmdom dom =
360 let
361 val (_, bio) = requestBio (fn () => ())
362 in
363 Msg.send (bio, MsgRmdom dom);
364 case Msg.recv bio of
365 NONE => print "Server closed connection unexpectedly.\n"
366 | SOME m =>
367 case m of
368 MsgOk => print "Removal succeeded.\n"
369 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
370 | _ => print "Unexpected server reply.\n";
371 OpenSSL.close bio
372 end
373
e69e60cc
AC
374fun requestRmuser user =
375 let
376 val (_, bio) = requestBio (fn () => ())
377 in
378 Msg.send (bio, MsgRmuser user);
379 case Msg.recv bio of
380 NONE => print "Server closed connection unexpectedly.\n"
381 | SOME m =>
382 case m of
383 MsgOk => print "Removal succeeded.\n"
384 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
385 | _ => print "Unexpected server reply.\n";
386 OpenSSL.close bio
387 end
388
d541c618
AC
389fun requestDbUser dbtype =
390 let
391 val (_, bio) = requestBio (fn () => ())
392 in
393 Msg.send (bio, MsgCreateDbUser dbtype);
394 case Msg.recv bio of
395 NONE => print "Server closed connection unexpectedly.\n"
396 | SOME m =>
397 case m of
398 MsgOk => print "Your user has been created.\n"
399 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
400 | _ => print "Unexpected server reply.\n";
401 OpenSSL.close bio
402 end
403
90dd48df
AC
404fun requestDbTable p =
405 let
406 val (user, bio) = requestBio (fn () => ())
407 in
408 Msg.send (bio, MsgCreateDbTable p);
409 case Msg.recv bio of
410 NONE => print "Server closed connection unexpectedly.\n"
411 | SOME m =>
412 case m of
413 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
414 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
415 | _ => print "Unexpected server reply.\n";
416 OpenSSL.close bio
417 end
418
1d3ef80e
AC
419fun requestListMailboxes domain =
420 let
421 val (_, bio) = requestBio (fn () => ())
422 in
423 Msg.send (bio, MsgListMailboxes domain);
424 (case Msg.recv bio of
425 NONE => Vmail.Error "Server closed connection unexpectedly.\n"
426 | SOME m =>
427 case m of
428 MsgMailboxes users => (Msg.send (bio, MsgOk);
429 Vmail.Listing users)
430 | MsgError s => Vmail.Error ("Creation failed: " ^ s)
431 | _ => Vmail.Error "Unexpected server reply.\n")
432 before OpenSSL.close bio
433 end
434
08688401
AC
435fun requestNewMailbox p =
436 let
437 val (_, bio) = requestBio (fn () => ())
438 in
439 Msg.send (bio, MsgNewMailbox p);
440 case Msg.recv bio of
441 NONE => print "Server closed connection unexpectedly.\n"
442 | SOME m =>
443 case m of
444 MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")
445 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
446 | _ => print "Unexpected server reply.\n";
447 OpenSSL.close bio
448 end
449
450fun requestPasswdMailbox p =
451 let
452 val (_, bio) = requestBio (fn () => ())
453 in
454 Msg.send (bio, MsgPasswdMailbox p);
455 case Msg.recv bio of
456 NONE => print "Server closed connection unexpectedly.\n"
457 | SOME m =>
458 case m of
459 MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
460 | MsgError s => print ("Set failed: " ^ s ^ "\n")
461 | _ => print "Unexpected server reply.\n";
462 OpenSSL.close bio
463 end
464
465fun requestRmMailbox p =
466 let
467 val (_, bio) = requestBio (fn () => ())
468 in
469 Msg.send (bio, MsgRmMailbox p);
470 case Msg.recv bio of
471 NONE => print "Server closed connection unexpectedly.\n"
472 | SOME m =>
473 case m of
474 MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")
475 | MsgError s => print ("Remove failed: " ^ s ^ "\n")
476 | _ => print "Unexpected server reply.\n";
477 OpenSSL.close bio
478 end
479
71420f8b 480fun regenerate context =
1824f573
AC
481 let
482 val b = basis ()
71420f8b
AC
483 val () = Tycheck.disallowExterns ()
484
485 val () = Domain.resetGlobal ()
486
487 fun contactNode (node, ip) =
488 if node = Config.defaultNode then
489 Domain.resetLocal ()
490 else let
491 val bio = OpenSSL.connect (context,
492 ip
493 ^ ":"
494 ^ Int.toString Config.slavePort)
495 in
496 Msg.send (bio, MsgRegenerate);
497 case Msg.recv bio of
498 NONE => print "Slave closed connection unexpectedly\n"
499 | SOME m =>
500 case m of
501 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
502 | MsgError s => print ("Slave " ^ node
503 ^ " returned error: " ^
504 s ^ "\n")
505 | _ => print ("Slave " ^ node
506 ^ " returned unexpected command\n");
507 OpenSSL.close bio
508 end
1824f573
AC
509
510 fun doUser user =
511 let
512 val _ = Domain.setUser user
513 val _ = ErrorMsg.reset ()
514
515 val dname = Config.domtoolDir user
516
517 val dir = Posix.FileSys.opendir dname
518
519 fun loop files =
520 case Posix.FileSys.readdir dir of
521 NONE => (Posix.FileSys.closedir dir;
522 files)
523 | SOME fname =>
524 if notTmp fname then
525 loop (OS.Path.joinDirFile {dir = dname,
526 file = fname}
527 :: files)
528 else
529 loop files
530
531 val files = loop []
532 val (_, files) = Order.order (SOME b) files
533 in
534 if !ErrorMsg.anyErrors then
535 print ("User " ^ user ^ "'s configuration has errors!\n")
536 else
537 app eval' files
538 end
539 handle IO.Io _ => ()
540 | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
541 in
71420f8b 542 app contactNode Config.nodeIps;
1824f573
AC
543 Env.pre ();
544 app doUser (Acl.users ());
545 Env.post ()
546 end
547
e69e60cc
AC
548fun rmuser user =
549 let
550 val doms = Acl.class {user = user, class = "domain"}
551 val doms = List.filter (fn dom =>
552 case Acl.whoHas {class = "domain", value = dom} of
553 [_] => true
554 | _ => false) (StringSet.listItems doms)
555 in
556 Acl.rmuser user;
557 Domain.rmdom doms
558 end
559
3b267643 560fun service () =
07cc384c 561 let
aa56e112
AC
562 val () = Acl.read Config.aclFile
563
3b267643
AC
564 val context = OpenSSL.context (Config.serverCert,
565 Config.serverKey,
566 Config.trustStore)
36e42cb8 567 val _ = Domain.set_context context
3b267643 568
60534712 569 val sock = OpenSSL.listen (context, Config.dispatcherPort)
3b267643
AC
570
571 fun loop () =
60534712 572 case OpenSSL.accept sock of
3b267643
AC
573 NONE => ()
574 | SOME bio =>
575 let
aa56e112
AC
576 val user = OpenSSL.peerCN bio
577 val () = print ("\nConnection from " ^ user ^ "\n")
578 val () = Domain.setUser user
579
08688401
AC
580 fun doIt f cleanup =
581 ((case f () of
582 (msgLocal, SOME msgRemote) =>
583 (print msgLocal;
584 print "\n";
585 Msg.send (bio, MsgError msgRemote))
586 | (msgLocal, NONE) =>
587 (print msgLocal;
588 print "\n";
589 Msg.send (bio, MsgOk)))
590 handle OpenSSL.OpenSSL _ =>
591 print "OpenSSL error\n"
592 | OS.SysErr (s, _) =>
593 (print "System error: ";
594 print s;
595 print "\n";
596 Msg.send (bio, MsgError ("System error: " ^ s))
597 handle OpenSSL.OpenSSL _ => ())
598 | Fail s =>
599 (print "Failure: ";
600 print s;
601 print "\n";
602 Msg.send (bio, MsgError ("Failure: " ^ s))
603 handle OpenSSL.OpenSSL _ => ())
604 | ErrorMsg.Error =>
605 (print "Compilation error\n";
606 Msg.send (bio, MsgError "Error during configuration evaluation")
607 handle OpenSSL.OpenSSL _ => ());
608 (cleanup ();
609 ignore (OpenSSL.readChar bio);
610 OpenSSL.close bio)
611 handle OpenSSL.OpenSSL _ => ();
612 loop ())
613
c53e82e4
AC
614 fun doConfig codes =
615 let
616 val _ = print "Configuration:\n"
617 val _ = app (fn s => (print s; print "\n")) codes
618 val _ = print "\n"
619
620 val outname = OS.FileSys.tmpName ()
621
622 fun doOne code =
623 let
624 val outf = TextIO.openOut outname
625 in
626 TextIO.output (outf, code);
627 TextIO.closeOut outf;
1824f573 628 eval' outname
c53e82e4
AC
629 end
630 in
08688401
AC
631 doIt (fn () => (Env.pre ();
632 app doOne codes;
633 Env.post ();
634 Msg.send (bio, MsgOk);
635 ("Configuration complete.", NONE)))
636 (fn () => OS.FileSys.remove outname)
c53e82e4
AC
637 end
638
36e42cb8
AC
639 fun cmdLoop () =
640 case Msg.recv bio of
641 NONE => (OpenSSL.close bio
642 handle OpenSSL.OpenSSL _ => ();
643 loop ())
644 | SOME m =>
645 case m of
c53e82e4
AC
646 MsgConfig code => doConfig [code]
647 | MsgMultiConfig codes => doConfig codes
5ee41dd0
AC
648
649 | MsgGrant acl =>
08688401
AC
650 doIt (fn () =>
651 if Acl.query {user = user, class = "priv", value = "all"} then
652 (Acl.grant acl;
653 Acl.write Config.aclFile;
654 ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
655 NONE))
656 else
657 ("Unauthorized user asked to grant a permission!",
658 SOME "Not authorized to grant privileges"))
659 (fn () => ())
660
411a85f2 661 | MsgRevoke acl =>
08688401
AC
662 doIt (fn () =>
663 if Acl.query {user = user, class = "priv", value = "all"} then
664 (Acl.revoke acl;
665 Acl.write Config.aclFile;
666 ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
667 NONE))
668 else
669 ("Unauthorized user asked to revoke a permission!",
670 SOME "Not authorized to revoke privileges"))
671 (fn () => ())
5ee41dd0 672
08a04eb4 673 | MsgListPerms user =>
08688401
AC
674 doIt (fn () =>
675 (Msg.send (bio, MsgPerms (Acl.queryAll user));
676 ("Sent permission list for user " ^ user ^ ".",
677 NONE)))
678 (fn () => ())
08a04eb4 679
094877b1 680 | MsgWhoHas perm =>
08688401
AC
681 doIt (fn () =>
682 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
683 ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
684 NONE)))
685 (fn () => ())
094877b1 686
e69e60cc 687 | MsgRmdom doms =>
08688401
AC
688 doIt (fn () =>
689 if Acl.query {user = user, class = "priv", value = "all"}
690 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
691 (Domain.rmdom doms;
692 app (fn dom =>
693 Acl.revokeFromAll {class = "domain", value = dom}) doms;
694 Acl.write Config.aclFile;
695 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
696 NONE))
697 else
698 ("Unauthorized user asked to remove a domain!",
699 SOME "Not authorized to remove that domain"))
700 (fn () => ())
1824f573
AC
701
702 | MsgRegenerate =>
08688401
AC
703 doIt (fn () =>
704 if Acl.query {user = user, class = "priv", value = "regen"}
705 orelse Acl.query {user = user, class = "priv", value = "all"} then
706 (regenerate context;
707 ("Regenerated all configuration.",
708 NONE))
709 else
710 ("Unauthorized user asked to regenerate!",
711 SOME "Not authorized to regenerate"))
712 (fn () => ())
e69e60cc 713
05323cbc 714 | MsgRmuser user' =>
08688401
AC
715 doIt (fn () =>
716 if Acl.query {user = user, class = "priv", value = "all"} then
717 (rmuser user';
718 Acl.write Config.aclFile;
719 ("Removed user " ^ user' ^ ".",
720 NONE))
721 else
722 ("Unauthorized user asked to remove a user!",
723 SOME "Not authorized to remove users"))
724 (fn () => ())
d541c618 725
21d921a5 726 | MsgCreateDbUser {dbtype, passwd} =>
08688401
AC
727 doIt (fn () =>
728 case Dbms.lookup dbtype of
729 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
730 SOME ("Unknown database type " ^ dbtype))
731 | SOME handler =>
732 case #adduser handler {user = user, passwd = passwd} of
733 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
734 NONE)
735 | SOME msg =>
736 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
737 SOME ("Error adding user: " ^ msg)))
738 (fn () => ())
c189cbe9 739
90dd48df 740 | MsgCreateDbTable {dbtype, dbname} =>
08688401
AC
741 doIt (fn () =>
742 if Dbms.validDbname dbname then
743 case Dbms.lookup dbtype of
744 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
745 SOME ("Unknown database type " ^ dbtype))
746 | SOME handler =>
747 case #createdb handler {user = user, dbname = dbname} of
748 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
749 NONE)
750 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
751 SOME ("Error creating database: " ^ msg))
752 else
753 ("Invalid database name " ^ user ^ "_" ^ dbname,
754 SOME ("Invalid database name " ^ dbname)))
755 (fn () => ())
756
1d3ef80e
AC
757 | MsgListMailboxes domain =>
758 doIt (fn () =>
759 if not (Domain.yourDomain domain) then
760 ("User wasn't authorized to list mailboxes for " ^ domain,
761 SOME "You're not authorized to configure that domain.")
762 else
763 case Vmail.list domain of
764 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
765 ("Sent mailbox list for " ^ domain,
766 NONE))
767 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
768 SOME msg))
769 (fn () => ())
770
08688401
AC
771 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
772 doIt (fn () =>
773 if not (Domain.yourDomain domain) then
774 ("User wasn't authorized to add a mailbox to " ^ domain,
775 SOME "You're not authorized to configure that domain.")
776 else if not (Domain.validUser emailUser) then
777 ("Invalid e-mail username " ^ emailUser,
778 SOME "Invalid e-mail username")
779 else if not (CharVector.all Char.isGraph passwd) then
780 ("Invalid password",
781 SOME "Invalid password; may only contain printable, non-space characters")
782 else if not (Domain.yourPath mailbox) then
783 ("User wasn't authorized to add a mailbox at " ^ mailbox,
784 SOME "You're not authorized to use that mailbox location.")
785 else
786 case Vmail.add {requester = user,
787 domain = domain, user = emailUser,
788 passwd = passwd, mailbox = mailbox} of
789 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
790 NONE)
9ffe2f0f 791 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
08688401
AC
792 SOME msg))
793 (fn () => ())
794
795 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
796 doIt (fn () =>
797 if not (Domain.yourDomain domain) then
798 ("User wasn't authorized to change password of a mailbox for " ^ domain,
799 SOME "You're not authorized to configure that domain.")
800 else if not (Domain.validUser emailUser) then
801 ("Invalid e-mail username " ^ emailUser,
802 SOME "Invalid e-mail username")
803 else if not (CharVector.all Char.isGraph passwd) then
804 ("Invalid password",
805 SOME "Invalid password; may only contain printable, non-space characters")
806 else
807 case Vmail.passwd {domain = domain, user = emailUser,
808 passwd = passwd} of
809 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
810 NONE)
9ffe2f0f 811 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
08688401
AC
812 SOME msg))
813 (fn () => ())
814
815 | MsgRmMailbox {domain, user = emailUser} =>
816 doIt (fn () =>
817 if not (Domain.yourDomain domain) then
818 ("User wasn't authorized to change password of a mailbox for " ^ domain,
819 SOME "You're not authorized to configure that domain.")
820 else if not (Domain.validUser emailUser) then
821 ("Invalid e-mail username " ^ emailUser,
822 SOME "Invalid e-mail username")
823 else
824 case Vmail.rm {domain = domain, user = emailUser} of
825 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
826 NONE)
9ffe2f0f 827 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
08688401
AC
828 SOME msg))
829 (fn () => ())
90dd48df 830
36e42cb8 831 | _ =>
08688401
AC
832 doIt (fn () => ("Unexpected command",
833 SOME "Unexpected command"))
834 (fn () => ())
36e42cb8
AC
835 in
836 cmdLoop ()
837 end
97665758
AC
838 handle OpenSSL.OpenSSL s =>
839 (print ("OpenSSL error: " ^ s ^ "\n");
840 OpenSSL.close bio
841 handle OpenSSL.OpenSSL _ => ();
842 loop ())
843 | OS.SysErr (s, _) =>
844 (print ("System error: " ^ s ^ "\n");
845 OpenSSL.close bio
846 handle OpenSSL.OpenSSL _ => ();
847 loop ())
36e42cb8 848 in
361a1e7f 849 print "Listening for connections....\n";
36e42cb8
AC
850 loop ();
851 OpenSSL.shutdown sock
852 end
853
854fun slave () =
855 let
6e62228d 856 val host = Slave.hostname ()
36e42cb8
AC
857
858 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
a088cea6 859 Config.keyDir ^ "/" ^ host ^ "/key.pem",
36e42cb8
AC
860 Config.trustStore)
861
862 val sock = OpenSSL.listen (context, Config.slavePort)
863
864 fun loop () =
865 case OpenSSL.accept sock of
866 NONE => ()
867 | SOME bio =>
868 let
869 val peer = OpenSSL.peerCN bio
870 val () = print ("\nConnection from " ^ peer ^ "\n")
3b267643 871 in
36e42cb8
AC
872 if peer <> Config.dispatcherName then
873 (print "Not authorized!\n";
874 OpenSSL.close bio;
875 loop ())
876 else let
877 fun loop' files =
878 case Msg.recv bio of
879 NONE => print "Dispatcher closed connection unexpectedly\n"
880 | SOME m =>
881 case m of
882 MsgFile file => loop' (file :: files)
883 | MsgDoFiles => (Slave.handleChanges files;
884 Msg.send (bio, MsgOk))
71420f8b
AC
885 | MsgRegenerate => (Domain.resetLocal ();
886 Msg.send (bio, MsgOk))
36e42cb8
AC
887 | _ => (print "Dispatcher sent unexpected command\n";
888 Msg.send (bio, MsgError "Unexpected command"))
889 in
890 loop' [];
891 ignore (OpenSSL.readChar bio);
892 OpenSSL.close bio;
893 loop ()
894 end
3196000d
AC
895 end handle OpenSSL.OpenSSL s =>
896 (print ("OpenSSL error: "^ s ^ "\n");
897 OpenSSL.close bio
898 handle OpenSSL.OpenSSL _ => ();
899 loop ())
7af7d4cb
AC
900 | OS.SysErr (s, _) =>
901 (print ("System error: "^ s ^ "\n");
902 OpenSSL.close bio
903 handle OpenSSL.OpenSSL _ => ();
904 loop ())
07cc384c 905 in
3b267643
AC
906 loop ();
907 OpenSSL.shutdown sock
07cc384c
AC
908 end
909
44a5ce2f 910fun listBasis () =
3196000d
AC
911 let
912 val dir = Posix.FileSys.opendir Config.libRoot
913
914 fun loop files =
915 case Posix.FileSys.readdir dir of
916 NONE => (Posix.FileSys.closedir dir;
917 files)
918 | SOME fname =>
919 if String.isSuffix ".dtl" fname then
920 loop (OS.Path.joinDirFile {dir = Config.libRoot,
921 file = fname}
922 :: files)
923 else
924 loop files
3196000d 925 in
44a5ce2f 926 loop []
3196000d
AC
927 end
928
44a5ce2f
AC
929fun autodocBasis outdir =
930 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
931
234b917a 932end