smtplog
[hcoop/domtool2.git] / src / main.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 (* Main interface *)
20
21 structure Main :> MAIN = struct
22
23 open Ast MsgTypes Print
24
25 structure SM = StringMap
26
27 fun init () = Acl.read Config.aclFile
28
29 fun check' G fname =
30 let
31 val prog = Parse.parse fname
32 in
33 if !ErrorMsg.anyErrors then
34 G
35 else
36 Tycheck.checkFile G (Defaults.tInit ()) prog
37 end
38
39 fun basis () =
40 let
41 val dir = Posix.FileSys.opendir Config.libRoot
42
43 fun loop files =
44 case Posix.FileSys.readdir dir of
45 NONE => (Posix.FileSys.closedir dir;
46 files)
47 | SOME fname =>
48 if String.isSuffix ".dtl" fname then
49 loop (OS.Path.joinDirFile {dir = Config.libRoot,
50 file = fname}
51 :: files)
52 else
53 loop files
54
55 val files = loop []
56 val (_, files) = Order.order NONE files
57 in
58 if !ErrorMsg.anyErrors then
59 Env.empty
60 else
61 (Tycheck.allowExterns ();
62 foldl (fn (fname, G) => check' G fname) Env.empty files
63 before Tycheck.disallowExterns ())
64 end
65
66 fun check fname =
67 let
68 val _ = ErrorMsg.reset ()
69 val _ = Env.preTycheck ()
70
71 val b = basis ()
72 in
73 if !ErrorMsg.anyErrors then
74 raise ErrorMsg.Error
75 else
76 let
77 val _ = Tycheck.disallowExterns ()
78 val _ = ErrorMsg.reset ()
79 val prog = Parse.parse fname
80 in
81 if !ErrorMsg.anyErrors then
82 raise ErrorMsg.Error
83 else
84 let
85 val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
86 in
87 if !ErrorMsg.anyErrors then
88 raise ErrorMsg.Error
89 else
90 (G', #3 prog)
91 end
92 end
93 end
94
95 val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-")
96
97 fun 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
119 raise ErrorMsg.Error
120 else
121 (foldl (fn (fname, G) => check' G fname) b files;
122 if !ErrorMsg.anyErrors then
123 raise ErrorMsg.Error
124 else
125 ())
126 end
127
128 fun reduce fname =
129 let
130 val (G, body) = check fname
131 in
132 if !ErrorMsg.anyErrors then
133 NONE
134 else
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
147 end
148
149 fun eval fname =
150 case reduce fname of
151 (SOME body') =>
152 if !ErrorMsg.anyErrors then
153 raise ErrorMsg.Error
154 else
155 Eval.exec (Defaults.eInit ()) body'
156 | NONE => raise ErrorMsg.Error
157
158 fun 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
167 val dispatcher =
168 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
169
170 fun requestContext f =
171 let
172 val uid = Posix.ProcEnv.getuid ()
173 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
174
175 val () = Acl.read Config.aclFile
176 val () = Domain.setUser user
177
178 val () = f ()
179
180 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
181 Config.keyDir ^ "/" ^ user ^ "/key.pem",
182 Config.trustStore)
183 in
184 (user, context)
185 end
186
187 fun requestBio f =
188 let
189 val (user, context) = requestContext f
190 in
191 (user, OpenSSL.connect (context, dispatcher))
192 end
193
194 fun request fname =
195 let
196 val (user, bio) = requestBio (fn () => ignore (check fname))
197
198 val inf = TextIO.openIn fname
199
200 fun loop lines =
201 case TextIO.inputLine inf of
202 NONE => String.concat (List.rev lines)
203 | SOME line => loop (line :: lines)
204
205 val code = loop []
206 in
207 TextIO.closeIn inf;
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";
216 OpenSSL.close bio
217 end
218 handle ErrorMsg.Error => ()
219
220 fun requestDir dname =
221 let
222 val _ = ErrorMsg.reset ()
223
224 val (user, bio) = requestBio (fn () => checkDir dname)
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
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)
275 end
276 handle ErrorMsg.Error => ()
277
278 fun 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
293 fun 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
308 fun 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
326 fun 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
344 fun 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
359 fun 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
374 fun 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
389 fun 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
404 fun 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
419 fun 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."
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.")
432 before OpenSSL.close bio
433 end
434
435 fun 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
450 fun 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
465 fun 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
480 fun requestSaQuery addr =
481 let
482 val (_, bio) = requestBio (fn () => ())
483 in
484 Msg.send (bio, MsgSaQuery addr);
485 (case Msg.recv bio of
486 NONE => print "Server closed connection unexpectedly.\n"
487 | SOME m =>
488 case m of
489 MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is "
490 ^ (if b then "ON" else "OFF") ^ ".\n");
491 Msg.send (bio, MsgOk))
492 | MsgError s => print ("Query failed: " ^ s ^ "\n")
493 | _ => print "Unexpected server reply.\n")
494 before OpenSSL.close bio
495 end
496
497 fun requestSaSet p =
498 let
499 val (_, bio) = requestBio (fn () => ())
500 in
501 Msg.send (bio, MsgSaSet p);
502 case Msg.recv bio of
503 NONE => print "Server closed connection unexpectedly.\n"
504 | SOME m =>
505 case m of
506 MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now "
507 ^ (if #2 p then "ON" else "OFF") ^ ".\n")
508 | MsgError s => print ("Set failed: " ^ s ^ "\n")
509 | _ => print "Unexpected server reply.\n";
510 OpenSSL.close bio
511 end
512
513 fun requestSmtpLog domain =
514 let
515 val (_, bio) = requestBio (fn () => ())
516
517 val _ = Msg.send (bio, MsgSmtpLogReq domain)
518
519 fun loop () =
520 case Msg.recv bio of
521 NONE => print "Server closed connection unexpectedly.\n"
522 | SOME m =>
523 case m of
524 MsgOk => ()
525 | MsgSmtpLogRes line => (print line;
526 loop ())
527 | MsgError s => print ("Log search failed: " ^ s ^ "\n")
528 | _ => print "Unexpected server reply.\n"
529 in
530 loop ();
531 OpenSSL.close bio
532 end
533
534 fun regenerate context =
535 let
536 val b = basis ()
537 val () = Tycheck.disallowExterns ()
538
539 val () = Domain.resetGlobal ()
540
541 fun contactNode (node, ip) =
542 if node = Config.defaultNode then
543 Domain.resetLocal ()
544 else let
545 val bio = OpenSSL.connect (context,
546 ip
547 ^ ":"
548 ^ Int.toString Config.slavePort)
549 in
550 Msg.send (bio, MsgRegenerate);
551 case Msg.recv bio of
552 NONE => print "Slave closed connection unexpectedly\n"
553 | SOME m =>
554 case m of
555 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
556 | MsgError s => print ("Slave " ^ node
557 ^ " returned error: " ^
558 s ^ "\n")
559 | _ => print ("Slave " ^ node
560 ^ " returned unexpected command\n");
561 OpenSSL.close bio
562 end
563
564 fun doUser user =
565 let
566 val _ = Domain.setUser user
567 val _ = ErrorMsg.reset ()
568
569 val dname = Config.domtoolDir user
570
571 val dir = Posix.FileSys.opendir dname
572
573 fun loop files =
574 case Posix.FileSys.readdir dir of
575 NONE => (Posix.FileSys.closedir dir;
576 files)
577 | SOME fname =>
578 if notTmp fname then
579 loop (OS.Path.joinDirFile {dir = dname,
580 file = fname}
581 :: files)
582 else
583 loop files
584
585 val files = loop []
586 val (_, files) = Order.order (SOME b) files
587 in
588 if !ErrorMsg.anyErrors then
589 print ("User " ^ user ^ "'s configuration has errors!\n")
590 else
591 app eval' files
592 end
593 handle IO.Io _ => ()
594 | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
595 in
596 app contactNode Config.nodeIps;
597 Env.pre ();
598 app doUser (Acl.users ());
599 Env.post ()
600 end
601
602 fun rmuser user =
603 let
604 val doms = Acl.class {user = user, class = "domain"}
605 val doms = List.filter (fn dom =>
606 case Acl.whoHas {class = "domain", value = dom} of
607 [_] => true
608 | _ => false) (StringSet.listItems doms)
609 in
610 Acl.rmuser user;
611 Domain.rmdom doms
612 end
613
614 fun service () =
615 let
616 val () = Acl.read Config.aclFile
617
618 val context = OpenSSL.context (Config.serverCert,
619 Config.serverKey,
620 Config.trustStore)
621 val _ = Domain.set_context context
622
623 val sock = OpenSSL.listen (context, Config.dispatcherPort)
624
625 fun loop () =
626 case OpenSSL.accept sock of
627 NONE => ()
628 | SOME bio =>
629 let
630 val user = OpenSSL.peerCN bio
631 val () = print ("\nConnection from " ^ user ^ "\n")
632 val () = Domain.setUser user
633
634 fun doIt f cleanup =
635 ((case f () of
636 (msgLocal, SOME msgRemote) =>
637 (print msgLocal;
638 print "\n";
639 Msg.send (bio, MsgError msgRemote))
640 | (msgLocal, NONE) =>
641 (print msgLocal;
642 print "\n";
643 Msg.send (bio, MsgOk)))
644 handle OpenSSL.OpenSSL _ =>
645 print "OpenSSL error\n"
646 | OS.SysErr (s, _) =>
647 (print "System error: ";
648 print s;
649 print "\n";
650 Msg.send (bio, MsgError ("System error: " ^ s))
651 handle OpenSSL.OpenSSL _ => ())
652 | Fail s =>
653 (print "Failure: ";
654 print s;
655 print "\n";
656 Msg.send (bio, MsgError ("Failure: " ^ s))
657 handle OpenSSL.OpenSSL _ => ())
658 | ErrorMsg.Error =>
659 (print "Compilation error\n";
660 Msg.send (bio, MsgError "Error during configuration evaluation")
661 handle OpenSSL.OpenSSL _ => ());
662 (cleanup ();
663 ignore (OpenSSL.readChar bio);
664 OpenSSL.close bio)
665 handle OpenSSL.OpenSSL _ => ();
666 loop ())
667
668 fun doConfig codes =
669 let
670 val _ = print "Configuration:\n"
671 val _ = app (fn s => (print s; print "\n")) codes
672 val _ = print "\n"
673
674 val outname = OS.FileSys.tmpName ()
675
676 fun doOne code =
677 let
678 val outf = TextIO.openOut outname
679 in
680 TextIO.output (outf, code);
681 TextIO.closeOut outf;
682 eval' outname
683 end
684 in
685 doIt (fn () => (Env.pre ();
686 app doOne codes;
687 Env.post ();
688 Msg.send (bio, MsgOk);
689 ("Configuration complete.", NONE)))
690 (fn () => OS.FileSys.remove outname)
691 end
692
693 fun checkAddr s =
694 case String.fields (fn ch => ch = #"@") s of
695 [user'] =>
696 if user = user' then
697 SOME (SetSA.User s)
698 else
699 NONE
700 | [user', domain] =>
701 if Domain.validEmailUser user' andalso Domain.yourDomain domain then
702 SOME (SetSA.Email s)
703 else
704 NONE
705 | _ => NONE
706
707 fun cmdLoop () =
708 case Msg.recv bio of
709 NONE => (OpenSSL.close bio
710 handle OpenSSL.OpenSSL _ => ();
711 loop ())
712 | SOME m =>
713 case m of
714 MsgConfig code => doConfig [code]
715 | MsgMultiConfig codes => doConfig codes
716
717 | MsgGrant acl =>
718 doIt (fn () =>
719 if Acl.query {user = user, class = "priv", value = "all"} then
720 (Acl.grant acl;
721 Acl.write Config.aclFile;
722 ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
723 NONE))
724 else
725 ("Unauthorized user asked to grant a permission!",
726 SOME "Not authorized to grant privileges"))
727 (fn () => ())
728
729 | MsgRevoke acl =>
730 doIt (fn () =>
731 if Acl.query {user = user, class = "priv", value = "all"} then
732 (Acl.revoke acl;
733 Acl.write Config.aclFile;
734 ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
735 NONE))
736 else
737 ("Unauthorized user asked to revoke a permission!",
738 SOME "Not authorized to revoke privileges"))
739 (fn () => ())
740
741 | MsgListPerms user =>
742 doIt (fn () =>
743 (Msg.send (bio, MsgPerms (Acl.queryAll user));
744 ("Sent permission list for user " ^ user ^ ".",
745 NONE)))
746 (fn () => ())
747
748 | MsgWhoHas perm =>
749 doIt (fn () =>
750 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
751 ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
752 NONE)))
753 (fn () => ())
754
755 | MsgRmdom doms =>
756 doIt (fn () =>
757 if Acl.query {user = user, class = "priv", value = "all"}
758 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
759 (Domain.rmdom doms;
760 app (fn dom =>
761 Acl.revokeFromAll {class = "domain", value = dom}) doms;
762 Acl.write Config.aclFile;
763 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
764 NONE))
765 else
766 ("Unauthorized user asked to remove a domain!",
767 SOME "Not authorized to remove that domain"))
768 (fn () => ())
769
770 | MsgRegenerate =>
771 doIt (fn () =>
772 if Acl.query {user = user, class = "priv", value = "regen"}
773 orelse Acl.query {user = user, class = "priv", value = "all"} then
774 (regenerate context;
775 ("Regenerated all configuration.",
776 NONE))
777 else
778 ("Unauthorized user asked to regenerate!",
779 SOME "Not authorized to regenerate"))
780 (fn () => ())
781
782 | MsgRmuser user' =>
783 doIt (fn () =>
784 if Acl.query {user = user, class = "priv", value = "all"} then
785 (rmuser user';
786 Acl.write Config.aclFile;
787 ("Removed user " ^ user' ^ ".",
788 NONE))
789 else
790 ("Unauthorized user asked to remove a user!",
791 SOME "Not authorized to remove users"))
792 (fn () => ())
793
794 | MsgCreateDbUser {dbtype, passwd} =>
795 doIt (fn () =>
796 case Dbms.lookup dbtype of
797 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
798 SOME ("Unknown database type " ^ dbtype))
799 | SOME handler =>
800 case #adduser handler {user = user, passwd = passwd} of
801 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
802 NONE)
803 | SOME msg =>
804 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
805 SOME ("Error adding user: " ^ msg)))
806 (fn () => ())
807
808 | MsgCreateDbTable {dbtype, dbname} =>
809 doIt (fn () =>
810 if Dbms.validDbname dbname then
811 case Dbms.lookup dbtype of
812 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
813 SOME ("Unknown database type " ^ dbtype))
814 | SOME handler =>
815 case #createdb handler {user = user, dbname = dbname} of
816 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
817 NONE)
818 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
819 SOME ("Error creating database: " ^ msg))
820 else
821 ("Invalid database name " ^ user ^ "_" ^ dbname,
822 SOME ("Invalid database name " ^ dbname)))
823 (fn () => ())
824
825 | MsgListMailboxes domain =>
826 doIt (fn () =>
827 if not (Domain.yourDomain domain) then
828 ("User wasn't authorized to list mailboxes for " ^ domain,
829 SOME "You're not authorized to configure that domain.")
830 else
831 case Vmail.list domain of
832 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
833 ("Sent mailbox list for " ^ domain,
834 NONE))
835 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
836 SOME msg))
837 (fn () => ())
838
839 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
840 doIt (fn () =>
841 if not (Domain.yourDomain domain) then
842 ("User wasn't authorized to add a mailbox to " ^ domain,
843 SOME "You're not authorized to configure that domain.")
844 else if not (Domain.validEmailUser emailUser) then
845 ("Invalid e-mail username " ^ emailUser,
846 SOME "Invalid e-mail username")
847 else if not (CharVector.all Char.isGraph passwd) then
848 ("Invalid password",
849 SOME "Invalid password; may only contain printable, non-space characters")
850 else if not (Domain.yourPath mailbox) then
851 ("User wasn't authorized to add a mailbox at " ^ mailbox,
852 SOME "You're not authorized to use that mailbox location.")
853 else
854 case Vmail.add {requester = user,
855 domain = domain, user = emailUser,
856 passwd = passwd, mailbox = mailbox} of
857 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
858 NONE)
859 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
860 SOME msg))
861 (fn () => ())
862
863 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
864 doIt (fn () =>
865 if not (Domain.yourDomain domain) then
866 ("User wasn't authorized to change password of a mailbox for " ^ domain,
867 SOME "You're not authorized to configure that domain.")
868 else if not (Domain.validEmailUser emailUser) then
869 ("Invalid e-mail username " ^ emailUser,
870 SOME "Invalid e-mail username")
871 else if not (CharVector.all Char.isGraph passwd) then
872 ("Invalid password",
873 SOME "Invalid password; may only contain printable, non-space characters")
874 else
875 case Vmail.passwd {domain = domain, user = emailUser,
876 passwd = passwd} of
877 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
878 NONE)
879 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
880 SOME msg))
881 (fn () => ())
882
883 | MsgRmMailbox {domain, user = emailUser} =>
884 doIt (fn () =>
885 if not (Domain.yourDomain domain) then
886 ("User wasn't authorized to change password of a mailbox for " ^ domain,
887 SOME "You're not authorized to configure that domain.")
888 else if not (Domain.validEmailUser emailUser) then
889 ("Invalid e-mail username " ^ emailUser,
890 SOME "Invalid e-mail username")
891 else
892 case Vmail.rm {domain = domain, user = emailUser} of
893 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
894 NONE)
895 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
896 SOME msg))
897 (fn () => ())
898
899 | MsgSaQuery addr =>
900 doIt (fn () =>
901 case checkAddr addr of
902 NONE => ("User tried to query SA filtering for " ^ addr,
903 SOME "You aren't allowed to configure SA filtering for that recipient.")
904 | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
905 ("Queried SA filtering status for " ^ addr,
906 NONE)))
907 (fn () => ())
908
909 | MsgSaSet (addr, b) =>
910 doIt (fn () =>
911 case checkAddr addr of
912 NONE => ("User tried to set SA filtering for " ^ addr,
913 SOME "You aren't allowed to configure SA filtering for that recipient.")
914 | SOME addr' => (SetSA.set (addr', b);
915 Msg.send (bio, MsgOk);
916 ("Set SA filtering status for " ^ addr ^ " to "
917 ^ (if b then "ON" else "OFF"),
918 NONE)))
919 (fn () => ())
920
921 | MsgSmtpLogReq domain =>
922 doIt (fn () =>
923 if not (Domain.yourDomain domain) then
924 ("Unauthorized user tried to request SMTP logs for " ^ domain,
925 SOME "You aren't authorized to configure that domain.")
926 else
927 (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
928 domain;
929 ("Requested SMTP logs for " ^ domain,
930 NONE)))
931 (fn () => ())
932
933 | _ =>
934 doIt (fn () => ("Unexpected command",
935 SOME "Unexpected command"))
936 (fn () => ())
937 in
938 cmdLoop ()
939 end
940 handle OpenSSL.OpenSSL s =>
941 (print ("OpenSSL error: " ^ s ^ "\n");
942 OpenSSL.close bio
943 handle OpenSSL.OpenSSL _ => ();
944 loop ())
945 | OS.SysErr (s, _) =>
946 (print ("System error: " ^ s ^ "\n");
947 OpenSSL.close bio
948 handle OpenSSL.OpenSSL _ => ();
949 loop ())
950 in
951 print "Listening for connections....\n";
952 loop ();
953 OpenSSL.shutdown sock
954 end
955
956 fun slave () =
957 let
958 val host = Slave.hostname ()
959
960 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
961 Config.keyDir ^ "/" ^ host ^ "/key.pem",
962 Config.trustStore)
963
964 val sock = OpenSSL.listen (context, Config.slavePort)
965
966 fun loop () =
967 case OpenSSL.accept sock of
968 NONE => ()
969 | SOME bio =>
970 let
971 val peer = OpenSSL.peerCN bio
972 val () = print ("\nConnection from " ^ peer ^ "\n")
973 in
974 if peer <> Config.dispatcherName then
975 (print "Not authorized!\n";
976 OpenSSL.close bio;
977 loop ())
978 else let
979 fun loop' files =
980 case Msg.recv bio of
981 NONE => print "Dispatcher closed connection unexpectedly\n"
982 | SOME m =>
983 case m of
984 MsgFile file => loop' (file :: files)
985 | MsgDoFiles => (Slave.handleChanges files;
986 Msg.send (bio, MsgOk))
987 | MsgRegenerate => (Domain.resetLocal ();
988 Msg.send (bio, MsgOk))
989 | _ => (print "Dispatcher sent unexpected command\n";
990 Msg.send (bio, MsgError "Unexpected command"))
991 in
992 loop' [];
993 ignore (OpenSSL.readChar bio);
994 OpenSSL.close bio;
995 loop ()
996 end
997 end handle OpenSSL.OpenSSL s =>
998 (print ("OpenSSL error: "^ s ^ "\n");
999 OpenSSL.close bio
1000 handle OpenSSL.OpenSSL _ => ();
1001 loop ())
1002 | OS.SysErr (s, _) =>
1003 (print ("System error: "^ s ^ "\n");
1004 OpenSSL.close bio
1005 handle OpenSSL.OpenSSL _ => ();
1006 loop ())
1007 in
1008 loop ();
1009 OpenSSL.shutdown sock
1010 end
1011
1012 fun listBasis () =
1013 let
1014 val dir = Posix.FileSys.opendir Config.libRoot
1015
1016 fun loop files =
1017 case Posix.FileSys.readdir dir of
1018 NONE => (Posix.FileSys.closedir dir;
1019 files)
1020 | SOME fname =>
1021 if String.isSuffix ".dtl" fname then
1022 loop (OS.Path.joinDirFile {dir = Config.libRoot,
1023 file = fname}
1024 :: files)
1025 else
1026 loop files
1027 in
1028 loop []
1029 end
1030
1031 fun autodocBasis outdir =
1032 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1033
1034 end