First vmail support
[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
08688401
AC
419fun requestNewMailbox p =
420 let
421 val (_, bio) = requestBio (fn () => ())
422 in
423 Msg.send (bio, MsgNewMailbox p);
424 case Msg.recv bio of
425 NONE => print "Server closed connection unexpectedly.\n"
426 | SOME m =>
427 case m of
428 MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")
429 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
430 | _ => print "Unexpected server reply.\n";
431 OpenSSL.close bio
432 end
433
434fun requestPasswdMailbox p =
435 let
436 val (_, bio) = requestBio (fn () => ())
437 in
438 Msg.send (bio, MsgPasswdMailbox p);
439 case Msg.recv bio of
440 NONE => print "Server closed connection unexpectedly.\n"
441 | SOME m =>
442 case m of
443 MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
444 | MsgError s => print ("Set failed: " ^ s ^ "\n")
445 | _ => print "Unexpected server reply.\n";
446 OpenSSL.close bio
447 end
448
449fun requestRmMailbox p =
450 let
451 val (_, bio) = requestBio (fn () => ())
452 in
453 Msg.send (bio, MsgRmMailbox p);
454 case Msg.recv bio of
455 NONE => print "Server closed connection unexpectedly.\n"
456 | SOME m =>
457 case m of
458 MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")
459 | MsgError s => print ("Remove failed: " ^ s ^ "\n")
460 | _ => print "Unexpected server reply.\n";
461 OpenSSL.close bio
462 end
463
71420f8b 464fun regenerate context =
1824f573
AC
465 let
466 val b = basis ()
71420f8b
AC
467 val () = Tycheck.disallowExterns ()
468
469 val () = Domain.resetGlobal ()
470
471 fun contactNode (node, ip) =
472 if node = Config.defaultNode then
473 Domain.resetLocal ()
474 else let
475 val bio = OpenSSL.connect (context,
476 ip
477 ^ ":"
478 ^ Int.toString Config.slavePort)
479 in
480 Msg.send (bio, MsgRegenerate);
481 case Msg.recv bio of
482 NONE => print "Slave closed connection unexpectedly\n"
483 | SOME m =>
484 case m of
485 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
486 | MsgError s => print ("Slave " ^ node
487 ^ " returned error: " ^
488 s ^ "\n")
489 | _ => print ("Slave " ^ node
490 ^ " returned unexpected command\n");
491 OpenSSL.close bio
492 end
1824f573
AC
493
494 fun doUser user =
495 let
496 val _ = Domain.setUser user
497 val _ = ErrorMsg.reset ()
498
499 val dname = Config.domtoolDir user
500
501 val dir = Posix.FileSys.opendir dname
502
503 fun loop files =
504 case Posix.FileSys.readdir dir of
505 NONE => (Posix.FileSys.closedir dir;
506 files)
507 | SOME fname =>
508 if notTmp fname then
509 loop (OS.Path.joinDirFile {dir = dname,
510 file = fname}
511 :: files)
512 else
513 loop files
514
515 val files = loop []
516 val (_, files) = Order.order (SOME b) files
517 in
518 if !ErrorMsg.anyErrors then
519 print ("User " ^ user ^ "'s configuration has errors!\n")
520 else
521 app eval' files
522 end
523 handle IO.Io _ => ()
524 | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
525 in
71420f8b 526 app contactNode Config.nodeIps;
1824f573
AC
527 Env.pre ();
528 app doUser (Acl.users ());
529 Env.post ()
530 end
531
e69e60cc
AC
532fun rmuser user =
533 let
534 val doms = Acl.class {user = user, class = "domain"}
535 val doms = List.filter (fn dom =>
536 case Acl.whoHas {class = "domain", value = dom} of
537 [_] => true
538 | _ => false) (StringSet.listItems doms)
539 in
540 Acl.rmuser user;
541 Domain.rmdom doms
542 end
543
3b267643 544fun service () =
07cc384c 545 let
aa56e112
AC
546 val () = Acl.read Config.aclFile
547
3b267643
AC
548 val context = OpenSSL.context (Config.serverCert,
549 Config.serverKey,
550 Config.trustStore)
36e42cb8 551 val _ = Domain.set_context context
3b267643 552
60534712 553 val sock = OpenSSL.listen (context, Config.dispatcherPort)
3b267643
AC
554
555 fun loop () =
60534712 556 case OpenSSL.accept sock of
3b267643
AC
557 NONE => ()
558 | SOME bio =>
559 let
aa56e112
AC
560 val user = OpenSSL.peerCN bio
561 val () = print ("\nConnection from " ^ user ^ "\n")
562 val () = Domain.setUser user
563
08688401
AC
564 fun doIt f cleanup =
565 ((case f () of
566 (msgLocal, SOME msgRemote) =>
567 (print msgLocal;
568 print "\n";
569 Msg.send (bio, MsgError msgRemote))
570 | (msgLocal, NONE) =>
571 (print msgLocal;
572 print "\n";
573 Msg.send (bio, MsgOk)))
574 handle OpenSSL.OpenSSL _ =>
575 print "OpenSSL error\n"
576 | OS.SysErr (s, _) =>
577 (print "System error: ";
578 print s;
579 print "\n";
580 Msg.send (bio, MsgError ("System error: " ^ s))
581 handle OpenSSL.OpenSSL _ => ())
582 | Fail s =>
583 (print "Failure: ";
584 print s;
585 print "\n";
586 Msg.send (bio, MsgError ("Failure: " ^ s))
587 handle OpenSSL.OpenSSL _ => ())
588 | ErrorMsg.Error =>
589 (print "Compilation error\n";
590 Msg.send (bio, MsgError "Error during configuration evaluation")
591 handle OpenSSL.OpenSSL _ => ());
592 (cleanup ();
593 ignore (OpenSSL.readChar bio);
594 OpenSSL.close bio)
595 handle OpenSSL.OpenSSL _ => ();
596 loop ())
597
c53e82e4
AC
598 fun doConfig codes =
599 let
600 val _ = print "Configuration:\n"
601 val _ = app (fn s => (print s; print "\n")) codes
602 val _ = print "\n"
603
604 val outname = OS.FileSys.tmpName ()
605
606 fun doOne code =
607 let
608 val outf = TextIO.openOut outname
609 in
610 TextIO.output (outf, code);
611 TextIO.closeOut outf;
1824f573 612 eval' outname
c53e82e4
AC
613 end
614 in
08688401
AC
615 doIt (fn () => (Env.pre ();
616 app doOne codes;
617 Env.post ();
618 Msg.send (bio, MsgOk);
619 ("Configuration complete.", NONE)))
620 (fn () => OS.FileSys.remove outname)
c53e82e4
AC
621 end
622
36e42cb8
AC
623 fun cmdLoop () =
624 case Msg.recv bio of
625 NONE => (OpenSSL.close bio
626 handle OpenSSL.OpenSSL _ => ();
627 loop ())
628 | SOME m =>
629 case m of
c53e82e4
AC
630 MsgConfig code => doConfig [code]
631 | MsgMultiConfig codes => doConfig codes
5ee41dd0
AC
632
633 | MsgGrant acl =>
08688401
AC
634 doIt (fn () =>
635 if Acl.query {user = user, class = "priv", value = "all"} then
636 (Acl.grant acl;
637 Acl.write Config.aclFile;
638 ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
639 NONE))
640 else
641 ("Unauthorized user asked to grant a permission!",
642 SOME "Not authorized to grant privileges"))
643 (fn () => ())
644
411a85f2 645 | MsgRevoke acl =>
08688401
AC
646 doIt (fn () =>
647 if Acl.query {user = user, class = "priv", value = "all"} then
648 (Acl.revoke acl;
649 Acl.write Config.aclFile;
650 ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
651 NONE))
652 else
653 ("Unauthorized user asked to revoke a permission!",
654 SOME "Not authorized to revoke privileges"))
655 (fn () => ())
5ee41dd0 656
08a04eb4 657 | MsgListPerms user =>
08688401
AC
658 doIt (fn () =>
659 (Msg.send (bio, MsgPerms (Acl.queryAll user));
660 ("Sent permission list for user " ^ user ^ ".",
661 NONE)))
662 (fn () => ())
08a04eb4 663
094877b1 664 | MsgWhoHas perm =>
08688401
AC
665 doIt (fn () =>
666 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
667 ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
668 NONE)))
669 (fn () => ())
094877b1 670
e69e60cc 671 | MsgRmdom doms =>
08688401
AC
672 doIt (fn () =>
673 if Acl.query {user = user, class = "priv", value = "all"}
674 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
675 (Domain.rmdom doms;
676 app (fn dom =>
677 Acl.revokeFromAll {class = "domain", value = dom}) doms;
678 Acl.write Config.aclFile;
679 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
680 NONE))
681 else
682 ("Unauthorized user asked to remove a domain!",
683 SOME "Not authorized to remove that domain"))
684 (fn () => ())
1824f573
AC
685
686 | MsgRegenerate =>
08688401
AC
687 doIt (fn () =>
688 if Acl.query {user = user, class = "priv", value = "regen"}
689 orelse Acl.query {user = user, class = "priv", value = "all"} then
690 (regenerate context;
691 ("Regenerated all configuration.",
692 NONE))
693 else
694 ("Unauthorized user asked to regenerate!",
695 SOME "Not authorized to regenerate"))
696 (fn () => ())
e69e60cc 697
05323cbc 698 | MsgRmuser user' =>
08688401
AC
699 doIt (fn () =>
700 if Acl.query {user = user, class = "priv", value = "all"} then
701 (rmuser user';
702 Acl.write Config.aclFile;
703 ("Removed user " ^ user' ^ ".",
704 NONE))
705 else
706 ("Unauthorized user asked to remove a user!",
707 SOME "Not authorized to remove users"))
708 (fn () => ())
d541c618 709
21d921a5 710 | MsgCreateDbUser {dbtype, passwd} =>
08688401
AC
711 doIt (fn () =>
712 case Dbms.lookup dbtype of
713 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
714 SOME ("Unknown database type " ^ dbtype))
715 | SOME handler =>
716 case #adduser handler {user = user, passwd = passwd} of
717 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
718 NONE)
719 | SOME msg =>
720 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
721 SOME ("Error adding user: " ^ msg)))
722 (fn () => ())
c189cbe9 723
90dd48df 724 | MsgCreateDbTable {dbtype, dbname} =>
08688401
AC
725 doIt (fn () =>
726 if Dbms.validDbname dbname then
727 case Dbms.lookup dbtype of
728 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
729 SOME ("Unknown database type " ^ dbtype))
730 | SOME handler =>
731 case #createdb handler {user = user, dbname = dbname} of
732 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
733 NONE)
734 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
735 SOME ("Error creating database: " ^ msg))
736 else
737 ("Invalid database name " ^ user ^ "_" ^ dbname,
738 SOME ("Invalid database name " ^ dbname)))
739 (fn () => ())
740
741 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
742 doIt (fn () =>
743 if not (Domain.yourDomain domain) then
744 ("User wasn't authorized to add a mailbox to " ^ domain,
745 SOME "You're not authorized to configure that domain.")
746 else if not (Domain.validUser emailUser) then
747 ("Invalid e-mail username " ^ emailUser,
748 SOME "Invalid e-mail username")
749 else if not (CharVector.all Char.isGraph passwd) then
750 ("Invalid password",
751 SOME "Invalid password; may only contain printable, non-space characters")
752 else if not (Domain.yourPath mailbox) then
753 ("User wasn't authorized to add a mailbox at " ^ mailbox,
754 SOME "You're not authorized to use that mailbox location.")
755 else
756 case Vmail.add {requester = user,
757 domain = domain, user = emailUser,
758 passwd = passwd, mailbox = mailbox} of
759 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
760 NONE)
761 | SOME msg => ("Error adding mailbox: " ^ msg,
762 SOME msg))
763 (fn () => ())
764
765 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
766 doIt (fn () =>
767 if not (Domain.yourDomain domain) then
768 ("User wasn't authorized to change password of a mailbox for " ^ domain,
769 SOME "You're not authorized to configure that domain.")
770 else if not (Domain.validUser emailUser) then
771 ("Invalid e-mail username " ^ emailUser,
772 SOME "Invalid e-mail username")
773 else if not (CharVector.all Char.isGraph passwd) then
774 ("Invalid password",
775 SOME "Invalid password; may only contain printable, non-space characters")
776 else
777 case Vmail.passwd {domain = domain, user = emailUser,
778 passwd = passwd} of
779 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
780 NONE)
781 | SOME msg => ("Error changing mailbox password: " ^ msg,
782 SOME msg))
783 (fn () => ())
784
785 | MsgRmMailbox {domain, user = emailUser} =>
786 doIt (fn () =>
787 if not (Domain.yourDomain domain) then
788 ("User wasn't authorized to change password of a mailbox for " ^ domain,
789 SOME "You're not authorized to configure that domain.")
790 else if not (Domain.validUser emailUser) then
791 ("Invalid e-mail username " ^ emailUser,
792 SOME "Invalid e-mail username")
793 else
794 case Vmail.rm {domain = domain, user = emailUser} of
795 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
796 NONE)
797 | SOME msg => ("Error deleting mailbox: " ^ msg,
798 SOME msg))
799 (fn () => ())
90dd48df 800
36e42cb8 801 | _ =>
08688401
AC
802 doIt (fn () => ("Unexpected command",
803 SOME "Unexpected command"))
804 (fn () => ())
36e42cb8
AC
805 in
806 cmdLoop ()
807 end
97665758
AC
808 handle OpenSSL.OpenSSL s =>
809 (print ("OpenSSL error: " ^ s ^ "\n");
810 OpenSSL.close bio
811 handle OpenSSL.OpenSSL _ => ();
812 loop ())
813 | OS.SysErr (s, _) =>
814 (print ("System error: " ^ s ^ "\n");
815 OpenSSL.close bio
816 handle OpenSSL.OpenSSL _ => ();
817 loop ())
36e42cb8 818 in
361a1e7f 819 print "Listening for connections....\n";
36e42cb8
AC
820 loop ();
821 OpenSSL.shutdown sock
822 end
823
824fun slave () =
825 let
6e62228d 826 val host = Slave.hostname ()
36e42cb8
AC
827
828 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
a088cea6 829 Config.keyDir ^ "/" ^ host ^ "/key.pem",
36e42cb8
AC
830 Config.trustStore)
831
832 val sock = OpenSSL.listen (context, Config.slavePort)
833
834 fun loop () =
835 case OpenSSL.accept sock of
836 NONE => ()
837 | SOME bio =>
838 let
839 val peer = OpenSSL.peerCN bio
840 val () = print ("\nConnection from " ^ peer ^ "\n")
3b267643 841 in
36e42cb8
AC
842 if peer <> Config.dispatcherName then
843 (print "Not authorized!\n";
844 OpenSSL.close bio;
845 loop ())
846 else let
847 fun loop' files =
848 case Msg.recv bio of
849 NONE => print "Dispatcher closed connection unexpectedly\n"
850 | SOME m =>
851 case m of
852 MsgFile file => loop' (file :: files)
853 | MsgDoFiles => (Slave.handleChanges files;
854 Msg.send (bio, MsgOk))
71420f8b
AC
855 | MsgRegenerate => (Domain.resetLocal ();
856 Msg.send (bio, MsgOk))
36e42cb8
AC
857 | _ => (print "Dispatcher sent unexpected command\n";
858 Msg.send (bio, MsgError "Unexpected command"))
859 in
860 loop' [];
861 ignore (OpenSSL.readChar bio);
862 OpenSSL.close bio;
863 loop ()
864 end
3196000d
AC
865 end handle OpenSSL.OpenSSL s =>
866 (print ("OpenSSL error: "^ s ^ "\n");
867 OpenSSL.close bio
868 handle OpenSSL.OpenSSL _ => ();
869 loop ())
7af7d4cb
AC
870 | OS.SysErr (s, _) =>
871 (print ("System error: "^ s ^ "\n");
872 OpenSSL.close bio
873 handle OpenSSL.OpenSSL _ => ();
874 loop ())
07cc384c 875 in
3b267643
AC
876 loop ();
877 OpenSSL.shutdown sock
07cc384c
AC
878 end
879
44a5ce2f 880fun listBasis () =
3196000d
AC
881 let
882 val dir = Posix.FileSys.opendir Config.libRoot
883
884 fun loop files =
885 case Posix.FileSys.readdir dir of
886 NONE => (Posix.FileSys.closedir dir;
887 files)
888 | SOME fname =>
889 if String.isSuffix ".dtl" fname then
890 loop (OS.Path.joinDirFile {dir = Config.libRoot,
891 file = fname}
892 :: files)
893 else
894 loop files
3196000d 895 in
44a5ce2f 896 loop []
3196000d
AC
897 end
898
44a5ce2f
AC
899fun autodocBasis outdir =
900 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
901
234b917a 902end