Only one default alias per domain
[hcoop/domtool2.git] / src / main.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006-2007, 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 (Option.app (Unused.check G) (#3 prog);
37 Tycheck.checkFile G (Defaults.tInit ()) prog)
38 end
39
40 fun basis () =
41 let
42 val dir = Posix.FileSys.opendir Config.libRoot
43
44 fun loop files =
45 case Posix.FileSys.readdir dir of
46 NONE => (Posix.FileSys.closedir dir;
47 files)
48 | SOME fname =>
49 if String.isSuffix ".dtl" fname then
50 loop (OS.Path.joinDirFile {dir = Config.libRoot,
51 file = fname}
52 :: files)
53 else
54 loop files
55
56 val files = loop []
57 val (_, files) = Order.order NONE files
58 in
59 if !ErrorMsg.anyErrors then
60 Env.empty
61 else
62 (Tycheck.allowExterns ();
63 foldl (fn (fname, G) => check' G fname) Env.empty files
64 before Tycheck.disallowExterns ())
65 end
66
67 fun check fname =
68 let
69 val _ = ErrorMsg.reset ()
70 val _ = Env.preTycheck ()
71
72 val b = basis ()
73 in
74 if !ErrorMsg.anyErrors then
75 raise ErrorMsg.Error
76 else
77 let
78 val _ = Tycheck.disallowExterns ()
79 val _ = ErrorMsg.reset ()
80 val prog = Parse.parse fname
81 in
82 if !ErrorMsg.anyErrors then
83 raise ErrorMsg.Error
84 else
85 let
86 val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
87 in
88 if !ErrorMsg.anyErrors then
89 raise ErrorMsg.Error
90 else
91 (Option.app (Unused.check b) (#3 prog);
92 (G', #3 prog))
93 end
94 end
95 end
96
97 fun notTmp s =
98 String.sub (s, 0) <> #"."
99 andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") s
100
101 fun setupUser () =
102 let
103 val user =
104 case Posix.ProcEnv.getenv "DOMTOOL_USER" of
105 NONE =>
106 let
107 val uid = Posix.ProcEnv.getuid ()
108 in
109 Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
110 end
111 | SOME user => user
112 in
113 Acl.read Config.aclFile;
114 Domain.setUser user;
115 user
116 end
117
118 fun checkDir' dname =
119 let
120 val b = basis ()
121
122 val dir = Posix.FileSys.opendir dname
123
124 fun loop files =
125 case Posix.FileSys.readdir dir of
126 NONE => (Posix.FileSys.closedir dir;
127 files)
128 | SOME fname =>
129 if notTmp fname then
130 loop (OS.Path.joinDirFile {dir = dname,
131 file = fname}
132 :: files)
133 else
134 loop files
135
136 val files = loop []
137 val (_, files) = Order.order (SOME b) files
138 in
139 if !ErrorMsg.anyErrors then
140 raise ErrorMsg.Error
141 else
142 (foldl (fn (fname, G) => check' G fname) b files;
143 if !ErrorMsg.anyErrors then
144 raise ErrorMsg.Error
145 else
146 ())
147 end
148
149 fun checkDir dname =
150 (setupUser ();
151 checkDir' dname)
152
153 fun reduce fname =
154 let
155 val (G, body) = check fname
156 in
157 if !ErrorMsg.anyErrors then
158 NONE
159 else
160 case body of
161 SOME body =>
162 let
163 val body' = Reduce.reduceExp G body
164 in
165 (*printd (PD.hovBox (PD.PPS.Rel 0,
166 [PD.string "Result:",
167 PD.space 1,
168 p_exp body']))*)
169 SOME body'
170 end
171 | _ => NONE
172 end
173
174 fun eval fname =
175 case reduce fname of
176 (SOME body') =>
177 if !ErrorMsg.anyErrors then
178 raise ErrorMsg.Error
179 else
180 Eval.exec (Defaults.eInit ()) body'
181 | NONE => ()
182
183 fun eval' fname =
184 case reduce fname of
185 (SOME body') =>
186 if !ErrorMsg.anyErrors then
187 raise ErrorMsg.Error
188 else
189 ignore (Eval.exec' (Defaults.eInit ()) body')
190 | NONE => ()
191
192 val dispatcher =
193 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
194
195 val self =
196 "localhost:" ^ Int.toString Config.slavePort
197
198 fun context x =
199 (OpenSSL.context false x)
200 handle e as OpenSSL.OpenSSL s =>
201 (print "Couldn't find your certificate.\nYou probably haven't been given any Domtool privileges.\n";
202 print ("I looked in: " ^ #1 x ^ "\n");
203 print ("Additional information: " ^ s ^ "\n");
204 raise e)
205
206 fun requestContext f =
207 let
208 val user = setupUser ()
209
210 val () = f ()
211
212 val context = context (Config.certDir ^ "/" ^ user ^ ".pem",
213 Config.keyDir ^ "/" ^ user ^ "/key.pem",
214 Config.trustStore)
215 in
216 (user, context)
217 end
218
219 fun requestBio f =
220 let
221 val (user, context) = requestContext f
222 in
223 (user, OpenSSL.connect (context, dispatcher))
224 end
225
226 fun requestSlaveBio () =
227 let
228 val (user, context) = requestContext (fn () => ())
229 in
230 (user, OpenSSL.connect (context, self))
231 end
232
233 fun request fname =
234 let
235 val (user, bio) = requestBio (fn () => ignore (check fname))
236
237 val inf = TextIO.openIn fname
238
239 fun loop lines =
240 case TextIO.inputLine inf of
241 NONE => String.concat (List.rev lines)
242 | SOME line => loop (line :: lines)
243
244 val code = loop []
245 in
246 TextIO.closeIn inf;
247 Msg.send (bio, MsgConfig code);
248 case Msg.recv bio of
249 NONE => print "Server closed connection unexpectedly.\n"
250 | SOME m =>
251 case m of
252 MsgOk => print "Configuration succeeded.\n"
253 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
254 | _ => print "Unexpected server reply.\n";
255 OpenSSL.close bio
256 end
257 handle ErrorMsg.Error => ()
258
259 fun requestDir dname =
260 let
261 val _ = if Posix.FileSys.access (dname, []) then
262 ()
263 else
264 (print ("Can't access " ^ dname ^ ".\n");
265 print "Did you mean to run domtool on a specific file, instead of asking for all\n";
266 print "files in your ~/.domtool directory?\n";
267 OS.Process.exit OS.Process.failure)
268
269 val _ = ErrorMsg.reset ()
270
271 val (user, bio) = requestBio (fn () => checkDir' dname)
272
273 val b = basis ()
274
275 val dir = Posix.FileSys.opendir dname
276
277 fun loop files =
278 case Posix.FileSys.readdir dir of
279 NONE => (Posix.FileSys.closedir dir;
280 files)
281 | SOME fname =>
282 if notTmp fname then
283 loop (OS.Path.joinDirFile {dir = dname,
284 file = fname}
285 :: files)
286 else
287 loop files
288
289 val files = loop []
290 val (_, files) = Order.order (SOME b) files
291
292 val _ = if !ErrorMsg.anyErrors then
293 (print "J\n";raise ErrorMsg.Error)
294 else
295 ()
296
297 val codes = map (fn fname =>
298 let
299 val inf = TextIO.openIn fname
300
301 fun loop lines =
302 case TextIO.inputLine inf of
303 NONE => String.concat (rev lines)
304 | SOME line => loop (line :: lines)
305 in
306 loop []
307 before TextIO.closeIn inf
308 end) files
309 in
310 if !ErrorMsg.anyErrors then
311 ()
312 else
313 (Msg.send (bio, MsgMultiConfig codes);
314 case Msg.recv bio of
315 NONE => print "Server closed connection unexpectedly.\n"
316 | SOME m =>
317 case m of
318 MsgOk => print "Configuration succeeded.\n"
319 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
320 | _ => print "Unexpected server reply.\n";
321 OpenSSL.close bio)
322 end
323 handle ErrorMsg.Error => ()
324
325 fun requestPing () =
326 let
327 val (_, bio) = requestBio (fn () => ())
328 in
329 OpenSSL.close bio;
330 OS.Process.success
331 end
332 handle _ => OS.Process.failure
333
334 fun requestShutdown () =
335 let
336 val (_, bio) = requestBio (fn () => ())
337 in
338 Msg.send (bio, MsgShutdown);
339 case Msg.recv bio of
340 NONE => print "Server closed connection unexpectedly.\n"
341 | SOME m =>
342 case m of
343 MsgOk => print "Shutdown begun.\n"
344 | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
345 | _ => print "Unexpected server reply.\n";
346 OpenSSL.close bio
347 end
348
349 fun requestSlavePing () =
350 let
351 val (_, bio) = requestSlaveBio ()
352 in
353 OpenSSL.close bio;
354 OS.Process.success
355 end
356 handle _ => OS.Process.failure
357
358 fun requestSlaveShutdown () =
359 let
360 val (_, bio) = requestSlaveBio ()
361 in
362 Msg.send (bio, MsgShutdown);
363 case Msg.recv bio of
364 NONE => print "Server closed connection unexpectedly.\n"
365 | SOME m =>
366 case m of
367 MsgOk => print "Shutdown begun.\n"
368 | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
369 | _ => print "Unexpected server reply.\n";
370 OpenSSL.close bio
371 end
372
373 fun requestGrant acl =
374 let
375 val (user, bio) = requestBio (fn () => ())
376 in
377 Msg.send (bio, MsgGrant acl);
378 case Msg.recv bio of
379 NONE => print "Server closed connection unexpectedly.\n"
380 | SOME m =>
381 case m of
382 MsgOk => print "Grant succeeded.\n"
383 | MsgError s => print ("Grant failed: " ^ s ^ "\n")
384 | _ => print "Unexpected server reply.\n";
385 OpenSSL.close bio
386 end
387
388 fun requestRevoke acl =
389 let
390 val (user, bio) = requestBio (fn () => ())
391 in
392 Msg.send (bio, MsgRevoke acl);
393 case Msg.recv bio of
394 NONE => print "Server closed connection unexpectedly.\n"
395 | SOME m =>
396 case m of
397 MsgOk => print "Revoke succeeded.\n"
398 | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
399 | _ => print "Unexpected server reply.\n";
400 OpenSSL.close bio
401 end
402
403 fun requestListPerms user =
404 let
405 val (_, bio) = requestBio (fn () => ())
406 in
407 Msg.send (bio, MsgListPerms user);
408 (case Msg.recv bio of
409 NONE => (print "Server closed connection unexpectedly.\n";
410 NONE)
411 | SOME m =>
412 case m of
413 MsgPerms perms => SOME perms
414 | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
415 NONE)
416 | _ => (print "Unexpected server reply.\n";
417 NONE))
418 before OpenSSL.close bio
419 end
420
421 fun requestWhoHas perm =
422 let
423 val (_, bio) = requestBio (fn () => ())
424 in
425 Msg.send (bio, MsgWhoHas perm);
426 (case Msg.recv bio of
427 NONE => (print "Server closed connection unexpectedly.\n";
428 NONE)
429 | SOME m =>
430 case m of
431 MsgWhoHasResponse users => SOME users
432 | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
433 NONE)
434 | _ => (print "Unexpected server reply.\n";
435 NONE))
436 before OpenSSL.close bio
437 end
438
439 fun requestRegen () =
440 let
441 val (_, bio) = requestBio (fn () => ())
442 in
443 Msg.send (bio, MsgRegenerate);
444 case Msg.recv bio of
445 NONE => print "Server closed connection unexpectedly.\n"
446 | SOME m =>
447 case m of
448 MsgOk => print "Regeneration succeeded.\n"
449 | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
450 | _ => print "Unexpected server reply.\n";
451 OpenSSL.close bio
452 end
453
454 fun requestRegenTc () =
455 let
456 val (_, bio) = requestBio (fn () => ())
457 in
458 Msg.send (bio, MsgRegenerateTc);
459 case Msg.recv bio of
460 NONE => print "Server closed connection unexpectedly.\n"
461 | SOME m =>
462 case m of
463 MsgOk => print "All configuration validated.\n"
464 | MsgError s => print ("Configuration validation failed: " ^ s ^ "\n")
465 | _ => print "Unexpected server reply.\n";
466 OpenSSL.close bio
467 end
468
469 fun requestRmdom dom =
470 let
471 val (_, bio) = requestBio (fn () => ())
472 in
473 Msg.send (bio, MsgRmdom dom);
474 case Msg.recv bio of
475 NONE => print "Server closed connection unexpectedly.\n"
476 | SOME m =>
477 case m of
478 MsgOk => print "Removal succeeded.\n"
479 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
480 | _ => print "Unexpected server reply.\n";
481 OpenSSL.close bio
482 end
483
484 fun requestRmuser user =
485 let
486 val (_, bio) = requestBio (fn () => ())
487 in
488 Msg.send (bio, MsgRmuser user);
489 case Msg.recv bio of
490 NONE => print "Server closed connection unexpectedly.\n"
491 | SOME m =>
492 case m of
493 MsgOk => print "Removal succeeded.\n"
494 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
495 | _ => print "Unexpected server reply.\n";
496 OpenSSL.close bio
497 end
498
499 fun requestDbUser dbtype =
500 let
501 val (_, bio) = requestBio (fn () => ())
502 in
503 Msg.send (bio, MsgCreateDbUser dbtype);
504 case Msg.recv bio of
505 NONE => print "Server closed connection unexpectedly.\n"
506 | SOME m =>
507 case m of
508 MsgOk => print "Your user has been created.\n"
509 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
510 | _ => print "Unexpected server reply.\n";
511 OpenSSL.close bio
512 end
513
514 fun requestDbPasswd rc =
515 let
516 val (_, bio) = requestBio (fn () => ())
517 in
518 Msg.send (bio, MsgDbPasswd rc);
519 case Msg.recv bio of
520 NONE => print "Server closed connection unexpectedly.\n"
521 | SOME m =>
522 case m of
523 MsgOk => print "Your password has been changed.\n"
524 | MsgError s => print ("Password set failed: " ^ s ^ "\n")
525 | _ => print "Unexpected server reply.\n";
526 OpenSSL.close bio
527 end
528
529 fun requestDbTable p =
530 let
531 val (user, bio) = requestBio (fn () => ())
532 in
533 Msg.send (bio, MsgCreateDb p);
534 case Msg.recv bio of
535 NONE => print "Server closed connection unexpectedly.\n"
536 | SOME m =>
537 case m of
538 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
539 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
540 | _ => print "Unexpected server reply.\n";
541 OpenSSL.close bio
542 end
543
544 fun requestDbDrop p =
545 let
546 val (user, bio) = requestBio (fn () => ())
547 in
548 Msg.send (bio, MsgDropDb p);
549 case Msg.recv bio of
550 NONE => print "Server closed connection unexpectedly.\n"
551 | SOME m =>
552 case m of
553 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been dropped.\n")
554 | MsgError s => print ("Drop failed: " ^ s ^ "\n")
555 | _ => print "Unexpected server reply.\n";
556 OpenSSL.close bio
557 end
558
559 fun requestDbGrant p =
560 let
561 val (user, bio) = requestBio (fn () => ())
562 in
563 Msg.send (bio, MsgGrantDb p);
564 case Msg.recv bio of
565 NONE => print "Server closed connection unexpectedly.\n"
566 | SOME m =>
567 case m of
568 MsgOk => print ("You've been granted all allowed privileges to database " ^ user ^ "_" ^ #dbname p ^ ".\n")
569 | MsgError s => print ("Grant failed: " ^ s ^ "\n")
570 | _ => print "Unexpected server reply.\n";
571 OpenSSL.close bio
572 end
573
574 fun requestListMailboxes domain =
575 let
576 val (_, bio) = requestBio (fn () => ())
577 in
578 Msg.send (bio, MsgListMailboxes domain);
579 (case Msg.recv bio of
580 NONE => Vmail.Error "Server closed connection unexpectedly."
581 | SOME m =>
582 case m of
583 MsgMailboxes users => (Msg.send (bio, MsgOk);
584 Vmail.Listing users)
585 | MsgError s => Vmail.Error ("Listing failed: " ^ s)
586 | _ => Vmail.Error "Unexpected server reply.")
587 before OpenSSL.close bio
588 end
589
590 fun requestNewMailbox p =
591 let
592 val (_, bio) = requestBio (fn () => ())
593 in
594 Msg.send (bio, MsgNewMailbox p);
595 case Msg.recv bio of
596 NONE => print "Server closed connection unexpectedly.\n"
597 | SOME m =>
598 case m of
599 MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")
600 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
601 | _ => print "Unexpected server reply.\n";
602 OpenSSL.close bio
603 end
604
605 fun requestPasswdMailbox p =
606 let
607 val (_, bio) = requestBio (fn () => ())
608 in
609 Msg.send (bio, MsgPasswdMailbox p);
610 case Msg.recv bio of
611 NONE => print "Server closed connection unexpectedly.\n"
612 | SOME m =>
613 case m of
614 MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
615 | MsgError s => print ("Set failed: " ^ s ^ "\n")
616 | _ => print "Unexpected server reply.\n";
617 OpenSSL.close bio
618 end
619
620 fun requestRmMailbox p =
621 let
622 val (_, bio) = requestBio (fn () => ())
623 in
624 Msg.send (bio, MsgRmMailbox p);
625 case Msg.recv bio of
626 NONE => print "Server closed connection unexpectedly.\n"
627 | SOME m =>
628 case m of
629 MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")
630 | MsgError s => print ("Remove failed: " ^ s ^ "\n")
631 | _ => print "Unexpected server reply.\n";
632 OpenSSL.close bio
633 end
634
635 fun requestSaQuery addr =
636 let
637 val (_, bio) = requestBio (fn () => ())
638 in
639 Msg.send (bio, MsgSaQuery addr);
640 (case Msg.recv bio of
641 NONE => print "Server closed connection unexpectedly.\n"
642 | SOME m =>
643 case m of
644 MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is "
645 ^ (if b then "ON" else "OFF") ^ ".\n");
646 Msg.send (bio, MsgOk))
647 | MsgError s => print ("Query failed: " ^ s ^ "\n")
648 | _ => print "Unexpected server reply.\n")
649 before OpenSSL.close bio
650 end
651
652 fun requestSaSet p =
653 let
654 val (_, bio) = requestBio (fn () => ())
655 in
656 Msg.send (bio, MsgSaSet p);
657 case Msg.recv bio of
658 NONE => print "Server closed connection unexpectedly.\n"
659 | SOME m =>
660 case m of
661 MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now "
662 ^ (if #2 p then "ON" else "OFF") ^ ".\n")
663 | MsgError s => print ("Set failed: " ^ s ^ "\n")
664 | _ => print "Unexpected server reply.\n";
665 OpenSSL.close bio
666 end
667
668 fun requestSmtpLog domain =
669 let
670 val (_, bio) = requestBio (fn () => ())
671
672 val _ = Msg.send (bio, MsgSmtpLogReq domain)
673
674 fun loop () =
675 case Msg.recv bio of
676 NONE => print "Server closed connection unexpectedly.\n"
677 | SOME m =>
678 case m of
679 MsgOk => ()
680 | MsgSmtpLogRes line => (print line;
681 loop ())
682 | MsgError s => print ("Log search failed: " ^ s ^ "\n")
683 | _ => print "Unexpected server reply.\n"
684 in
685 loop ();
686 OpenSSL.close bio
687 end
688
689 fun requestMysqlFixperms () =
690 let
691 val (_, bio) = requestBio (fn () => ())
692 in
693 Msg.send (bio, MsgMysqlFixperms);
694 case Msg.recv bio of
695 NONE => print "Server closed connection unexpectedly.\n"
696 | SOME m =>
697 case m of
698 MsgOk => print "Permissions granted.\n"
699 | MsgError s => print ("Failed: " ^ s ^ "\n")
700 | _ => print "Unexpected server reply.\n";
701 OpenSSL.close bio
702 end
703
704 fun requestApt {node, pkg} =
705 let
706 val (user, context) = requestContext (fn () => ())
707 val bio = OpenSSL.connect (context, if node = Config.masterNode then
708 dispatcher
709 else
710 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
711
712 val _ = Msg.send (bio, MsgQuery (QApt pkg))
713
714 fun loop () =
715 case Msg.recv bio of
716 NONE => (print "Server closed connection unexpectedly.\n";
717 OS.Process.failure)
718 | SOME m =>
719 case m of
720 MsgYes => (print "Package is installed.\n";
721 OS.Process.success)
722 | MsgNo => (print "Package is not installed.\n";
723 OS.Process.failure)
724 | MsgError s => (print ("APT query failed: " ^ s ^ "\n");
725 OS.Process.failure)
726 | _ => (print "Unexpected server reply.\n";
727 OS.Process.failure)
728 in
729 loop ()
730 before OpenSSL.close bio
731 end
732
733 fun requestCron {node, uname} =
734 let
735 val (user, context) = requestContext (fn () => ())
736 val bio = OpenSSL.connect (context, if node = Config.masterNode then
737 dispatcher
738 else
739 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
740
741 val _ = Msg.send (bio, MsgQuery (QCron uname))
742
743 fun loop () =
744 case Msg.recv bio of
745 NONE => (print "Server closed connection unexpectedly.\n";
746 OS.Process.failure)
747 | SOME m =>
748 case m of
749 MsgYes => (print "User has cron permissions.\n";
750 OS.Process.success)
751 | MsgNo => (print "User does not have cron permissions.\n";
752 OS.Process.failure)
753 | MsgError s => (print ("Cron query failed: " ^ s ^ "\n");
754 OS.Process.failure)
755 | _ => (print "Unexpected server reply.\n";
756 OS.Process.failure)
757 in
758 loop ()
759 before OpenSSL.close bio
760 end
761
762 fun requestFtp {node, uname} =
763 let
764 val (user, context) = requestContext (fn () => ())
765 val bio = OpenSSL.connect (context, if node = Config.masterNode then
766 dispatcher
767 else
768 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
769
770 val _ = Msg.send (bio, MsgQuery (QFtp uname))
771
772 fun loop () =
773 case Msg.recv bio of
774 NONE => (print "Server closed connection unexpectedly.\n";
775 OS.Process.failure)
776 | SOME m =>
777 case m of
778 MsgYes => (print "User has FTP permissions.\n";
779 OS.Process.success)
780 | MsgNo => (print "User does not have FTP permissions.\n";
781 OS.Process.failure)
782 | MsgError s => (print ("FTP query failed: " ^ s ^ "\n");
783 OS.Process.failure)
784 | _ => (print "Unexpected server reply.\n";
785 OS.Process.failure)
786 in
787 loop ()
788 before OpenSSL.close bio
789 end
790
791 fun requestTrustedPath {node, uname} =
792 let
793 val (user, context) = requestContext (fn () => ())
794 val bio = OpenSSL.connect (context, if node = Config.masterNode then
795 dispatcher
796 else
797 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
798
799 val _ = Msg.send (bio, MsgQuery (QTrustedPath uname))
800
801 fun loop () =
802 case Msg.recv bio of
803 NONE => (print "Server closed connection unexpectedly.\n";
804 OS.Process.failure)
805 | SOME m =>
806 case m of
807 MsgYes => (print "User has trusted path restriction.\n";
808 OS.Process.success)
809 | MsgNo => (print "User does not have trusted path restriction.\n";
810 OS.Process.failure)
811 | MsgError s => (print ("Trusted path query failed: " ^ s ^ "\n");
812 OS.Process.failure)
813 | _ => (print "Unexpected server reply.\n";
814 OS.Process.failure)
815 in
816 loop ()
817 before OpenSSL.close bio
818 end
819
820 fun requestSocketPerm {node, uname} =
821 let
822 val (user, context) = requestContext (fn () => ())
823 val bio = OpenSSL.connect (context, if node = Config.masterNode then
824 dispatcher
825 else
826 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
827
828 val _ = Msg.send (bio, MsgQuery (QSocket uname))
829
830 fun loop () =
831 case Msg.recv bio of
832 NONE => (print "Server closed connection unexpectedly.\n";
833 OS.Process.failure)
834 | SOME m =>
835 case m of
836 MsgSocket p => (case p of
837 Any => print "Any\n"
838 | Client => print "Client\n"
839 | Server => print "Server\n"
840 | Nada => print "Nada\n";
841 OS.Process.success)
842 | MsgError s => (print ("Socket permission query failed: " ^ s ^ "\n");
843 OS.Process.failure)
844 | _ => (print "Unexpected server reply.\n";
845 OS.Process.failure)
846 in
847 loop ()
848 before OpenSSL.close bio
849 end
850
851 fun requestFirewall {node, uname} =
852 let
853 val (user, context) = requestContext (fn () => ())
854 val bio = OpenSSL.connect (context, if node = Config.masterNode then
855 dispatcher
856 else
857 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
858
859 val _ = Msg.send (bio, MsgQuery (QFirewall uname))
860
861 fun loop () =
862 case Msg.recv bio of
863 NONE => (print "Server closed connection unexpectedly.\n";
864 OS.Process.failure)
865 | SOME m =>
866 case m of
867 MsgFirewall ls => (app (fn s => (print s; print "\n")) ls;
868 OS.Process.success)
869 | MsgError s => (print ("Firewall query failed: " ^ s ^ "\n");
870 OS.Process.failure)
871 | _ => (print "Unexpected server reply.\n";
872 OS.Process.failure)
873 in
874 loop ()
875 before OpenSSL.close bio
876 end
877
878 fun requestDescribe dom =
879 let
880 val (_, bio) = requestBio (fn () => ())
881 in
882 Msg.send (bio, MsgDescribe dom);
883 case Msg.recv bio of
884 NONE => print "Server closed connection unexpectedly.\n"
885 | SOME m =>
886 case m of
887 MsgDescription s => print s
888 | MsgError s => print ("Description failed: " ^ s ^ "\n")
889 | _ => print "Unexpected server reply.\n";
890 OpenSSL.close bio
891 end
892
893 structure SS = StringSet
894
895 fun domainList dname =
896 let
897 val dir = Posix.FileSys.opendir dname
898
899 fun visitNode dset =
900 case Posix.FileSys.readdir dir of
901 NONE => dset
902 | SOME node =>
903 let
904 val path = OS.Path.joinDirFile {dir = dname,
905 file = node}
906
907 fun visitDomains (path, bfor, dset) =
908 let
909 val dir = Posix.FileSys.opendir path
910
911 fun loop dset =
912 case Posix.FileSys.readdir dir of
913 NONE => dset
914 | SOME dname =>
915 let
916 val path = OS.Path.joinDirFile {dir = path,
917 file = dname}
918 in
919 if Posix.FileSys.ST.isDir (Posix.FileSys.stat path) then
920 let
921 val bfor = dname :: bfor
922 in
923 loop (visitDomains (path, bfor,
924 SS.add (dset,
925 String.concatWith "." bfor)))
926 end
927 else
928 loop dset
929 end
930 in
931 loop dset
932 before Posix.FileSys.closedir dir
933 end
934 in
935 visitNode (visitDomains (path, [], dset))
936 end
937 in
938 visitNode SS.empty
939 before Posix.FileSys.closedir dir
940 end
941
942 fun regenerateEither tc checker context =
943 let
944 val () = print "Starting regeneration....\n"
945
946 val domainsBefore =
947 if tc then
948 SS.empty
949 else
950 domainList Config.resultRoot
951
952 fun ifReal f =
953 if tc then
954 ()
955 else
956 f ()
957
958 val _ = ErrorMsg.reset ()
959
960 val b = basis ()
961 val () = Tycheck.disallowExterns ()
962
963 val () = ifReal (fn () =>
964 (ignore (OS.Process.system ("rm -rf " ^ Config.oldResultRoot ^ "/*"));
965 ignore (OS.Process.system ("cp -r " ^ Config.resultRoot
966 ^ "/* " ^ Config.oldResultRoot ^ "/"));
967 Domain.resetGlobal ()))
968
969 val ok = ref true
970
971 fun contactNode (node, ip) =
972 if node = Config.defaultNode then
973 Domain.resetLocal ()
974 else let
975 val bio = OpenSSL.connect (context,
976 ip
977 ^ ":"
978 ^ Int.toString Config.slavePort)
979 in
980 Msg.send (bio, MsgRegenerate);
981 case Msg.recv bio of
982 NONE => print "Slave closed connection unexpectedly\n"
983 | SOME m =>
984 case m of
985 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
986 | MsgError s => print ("Slave " ^ node
987 ^ " returned error: " ^
988 s ^ "\n")
989 | _ => print ("Slave " ^ node
990 ^ " returned unexpected command\n");
991 OpenSSL.close bio
992 end
993 handle OpenSSL.OpenSSL s => print ("OpenSSL error: " ^ s ^ "\n")
994
995 fun doUser user =
996 let
997 val _ = Domain.setUser user
998 val _ = ErrorMsg.reset ()
999
1000 val dname = Config.domtoolDir user
1001 in
1002 if Posix.FileSys.access (dname, []) then
1003 let
1004 val dir = Posix.FileSys.opendir dname
1005
1006 fun loop files =
1007 case Posix.FileSys.readdir dir of
1008 NONE => (Posix.FileSys.closedir dir;
1009 files)
1010 | SOME fname =>
1011 if notTmp fname then
1012 loop (OS.Path.joinDirFile {dir = dname,
1013 file = fname}
1014 :: files)
1015 else
1016 loop files
1017
1018 val files = loop []
1019 val (_, files) = Order.order (SOME b) files
1020 in
1021 if !ErrorMsg.anyErrors then
1022 (ErrorMsg.reset ();
1023 print ("User " ^ user ^ "'s configuration has errors!\n");
1024 ok := false)
1025 else
1026 ();
1027 app checker files
1028 end
1029 else
1030 ()
1031 end
1032 handle IO.Io {name, function, ...} =>
1033 (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");
1034 ok := false)
1035 | exn as OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
1036 ok := false)
1037 | ErrorMsg.Error => (ErrorMsg.reset ();
1038 print ("User " ^ user ^ " had a compilation error.\n");
1039 ok := false)
1040 | _ => (print "Unknown exception during regeneration!\n";
1041 ok := false)
1042 in
1043 ifReal (fn () => (app contactNode Config.nodeIps;
1044 Env.pre ()));
1045 app doUser (Acl.users ());
1046 ifReal (fn () =>
1047 let
1048 val domainsAfter = domainList Config.resultRoot
1049 val domainsGone = SS.difference (domainsBefore, domainsAfter)
1050 in
1051 if SS.isEmpty domainsGone then
1052 ()
1053 else
1054 (print "Domains to kill:";
1055 SS.app (fn s => (print " "; print s)) domainsGone;
1056 print "\n";
1057
1058 Domain.rmdom' Config.oldResultRoot (SS.listItems domainsGone));
1059
1060 Env.post ()
1061 end);
1062 !ok
1063 end
1064
1065 val regenerate = regenerateEither false eval'
1066 val regenerateTc = regenerateEither true (ignore o check)
1067
1068 fun rmuser user =
1069 let
1070 val doms = Acl.class {user = user, class = "domain"}
1071 val doms = List.filter (fn dom =>
1072 case Acl.whoHas {class = "domain", value = dom} of
1073 [_] => true
1074 | _ => false) (StringSet.listItems doms)
1075 in
1076 Acl.rmuser user;
1077 Domain.rmdom doms
1078 end
1079
1080 fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
1081
1082 fun answerQuery q =
1083 case q of
1084 QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
1085 | QCron user => if Cron.allowed user then MsgYes else MsgNo
1086 | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
1087 | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
1088 | QSocket user => MsgSocket (SocketPerm.query user)
1089 | QFirewall user => MsgFirewall (Firewall.query user)
1090
1091 fun describeQuery q =
1092 case q of
1093 QApt pkg => "Requested installation status of package " ^ pkg
1094 | QCron user => "Asked about cron permissions for user " ^ user
1095 | QFtp user => "Asked about FTP permissions for user " ^ user
1096 | QTrustedPath user => "Asked about trusted path settings for user " ^ user
1097 | QSocket user => "Asked about socket permissions for user " ^ user
1098 | QFirewall user => "Asked about firewall rules for user " ^ user
1099
1100 fun service () =
1101 let
1102 val () = Acl.read Config.aclFile
1103
1104 val context = context (Config.serverCert,
1105 Config.serverKey,
1106 Config.trustStore)
1107 val _ = Domain.set_context context
1108
1109 val sock = OpenSSL.listen (context, Config.dispatcherPort)
1110
1111 fun loop () =
1112 (case OpenSSL.accept sock of
1113 NONE => ()
1114 | SOME bio =>
1115 let
1116 val user = OpenSSL.peerCN bio
1117 val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
1118 val () = Domain.setUser user
1119
1120 fun doIt f cleanup =
1121 ((case f () of
1122 (msgLocal, SOME msgRemote) =>
1123 (print msgLocal;
1124 print "\n";
1125 Msg.send (bio, MsgError msgRemote))
1126 | (msgLocal, NONE) =>
1127 (print msgLocal;
1128 print "\n";
1129 Msg.send (bio, MsgOk)))
1130 handle e as (OpenSSL.OpenSSL s) =>
1131 (print ("OpenSSL error: " ^ s ^ "\n");
1132 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1133 Msg.send (bio, MsgError ("OpenSSL error: " ^ s))
1134 handle OpenSSL.OpenSSL _ => ())
1135 | OS.SysErr (s, _) =>
1136 (print "System error: ";
1137 print s;
1138 print "\n";
1139 Msg.send (bio, MsgError ("System error: " ^ s))
1140 handle OpenSSL.OpenSSL _ => ())
1141 | Fail s =>
1142 (print "Failure: ";
1143 print s;
1144 print "\n";
1145 Msg.send (bio, MsgError ("Failure: " ^ s))
1146 handle OpenSSL.OpenSSL _ => ())
1147 | ErrorMsg.Error =>
1148 (print "Compilation error\n";
1149 Msg.send (bio, MsgError "Error during configuration evaluation")
1150 handle OpenSSL.OpenSSL _ => ());
1151 (cleanup ();
1152 ignore (OpenSSL.readChar bio);
1153 OpenSSL.close bio)
1154 handle OpenSSL.OpenSSL _ => ();
1155 loop ())
1156
1157 fun doConfig codes =
1158 let
1159 val _ = print "Configuration:\n"
1160 val _ = app (fn s => (print s; print "\n")) codes
1161 val _ = print "\n"
1162
1163 val outname = OS.FileSys.tmpName ()
1164
1165 fun doOne code =
1166 let
1167 val outf = TextIO.openOut outname
1168 in
1169 TextIO.output (outf, code);
1170 TextIO.closeOut outf;
1171 eval' outname
1172 end
1173 in
1174 doIt (fn () => (Env.pre ();
1175 app doOne codes;
1176 Env.post ();
1177 Msg.send (bio, MsgOk);
1178 ("Configuration complete.", NONE)))
1179 (fn () => OS.FileSys.remove outname)
1180 end
1181
1182 fun checkAddr s =
1183 case String.fields (fn ch => ch = #"@") s of
1184 [user'] =>
1185 if user = user' then
1186 SOME (SetSA.User s)
1187 else
1188 NONE
1189 | [user', domain] =>
1190 if Domain.validEmailUser user' andalso Domain.yourDomain domain then
1191 SOME (SetSA.Email s)
1192 else
1193 NONE
1194 | _ => NONE
1195
1196 fun cmdLoop () =
1197 case Msg.recv bio of
1198 NONE => (OpenSSL.close bio
1199 handle OpenSSL.OpenSSL _ => ();
1200 loop ())
1201 | SOME m =>
1202 case m of
1203 MsgConfig code => doConfig [code]
1204 | MsgMultiConfig codes => doConfig codes
1205
1206 | MsgShutdown =>
1207 if Acl.query {user = user, class = "priv", value = "all"}
1208 orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
1209 print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")
1210 else
1211 (print "Unauthorized shutdown command!\n";
1212 OpenSSL.close bio
1213 handle OpenSSL.OpenSSL _ => ();
1214 loop ())
1215
1216 | MsgGrant acl =>
1217 doIt (fn () =>
1218 if Acl.query {user = user, class = "priv", value = "all"} then
1219 (Acl.grant acl;
1220 Acl.write Config.aclFile;
1221 ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
1222 NONE))
1223 else
1224 ("Unauthorized user asked to grant a permission!",
1225 SOME "Not authorized to grant privileges"))
1226 (fn () => ())
1227
1228 | MsgRevoke acl =>
1229 doIt (fn () =>
1230 if Acl.query {user = user, class = "priv", value = "all"} then
1231 (Acl.revoke acl;
1232 Acl.write Config.aclFile;
1233 ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
1234 NONE))
1235 else
1236 ("Unauthorized user asked to revoke a permission!",
1237 SOME "Not authorized to revoke privileges"))
1238 (fn () => ())
1239
1240 | MsgListPerms user =>
1241 doIt (fn () =>
1242 (Msg.send (bio, MsgPerms (Acl.queryAll user));
1243 ("Sent permission list for user " ^ user ^ ".",
1244 NONE)))
1245 (fn () => ())
1246
1247 | MsgWhoHas perm =>
1248 doIt (fn () =>
1249 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
1250 ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
1251 NONE)))
1252 (fn () => ())
1253
1254 | MsgRmdom doms =>
1255 doIt (fn () =>
1256 if Acl.query {user = user, class = "priv", value = "all"}
1257 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
1258 (Domain.rmdom doms;
1259 app (fn dom =>
1260 Acl.revokeFromAll {class = "domain", value = dom}) doms;
1261 Acl.write Config.aclFile;
1262 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
1263 NONE))
1264 else
1265 ("Unauthorized user asked to remove a domain!",
1266 SOME "Not authorized to remove that domain"))
1267 (fn () => ())
1268
1269 | MsgRegenerate =>
1270 doIt (fn () =>
1271 if Acl.query {user = user, class = "priv", value = "regen"}
1272 orelse Acl.query {user = user, class = "priv", value = "all"} then
1273 (if regenerate context then
1274 ("Regenerated all configuration.",
1275 NONE)
1276 else
1277 ("Error regenerating configuration!",
1278 SOME "Error regenerating configuration! Consult /var/log/domtool.log."))
1279 else
1280 ("Unauthorized user asked to regenerate!",
1281 SOME "Not authorized to regenerate"))
1282 (fn () => ())
1283
1284 | MsgRegenerateTc =>
1285 doIt (fn () =>
1286 if Acl.query {user = user, class = "priv", value = "regen"}
1287 orelse Acl.query {user = user, class = "priv", value = "all"} then
1288 (if regenerateTc context then
1289 ("Checked all configuration.",
1290 NONE)
1291 else
1292 ("Found a compilation error!",
1293 SOME "Found a compilation error! Consult /var/log/domtool.log."))
1294 else
1295 ("Unauthorized user asked to regenerate -tc!",
1296 SOME "Not authorized to regenerate -tc"))
1297 (fn () => ())
1298
1299 | MsgRmuser user' =>
1300 doIt (fn () =>
1301 if Acl.query {user = user, class = "priv", value = "all"} then
1302 (rmuser user';
1303 Acl.write Config.aclFile;
1304 ("Removed user " ^ user' ^ ".",
1305 NONE))
1306 else
1307 ("Unauthorized user asked to remove a user!",
1308 SOME "Not authorized to remove users"))
1309 (fn () => ())
1310
1311 | MsgCreateDbUser {dbtype, passwd} =>
1312 doIt (fn () =>
1313 case Dbms.lookup dbtype of
1314 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
1315 SOME ("Unknown database type " ^ dbtype))
1316 | SOME handler =>
1317 case #adduser handler {user = user, passwd = passwd} of
1318 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
1319 NONE)
1320 | SOME msg =>
1321 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
1322 SOME ("Error adding user: " ^ msg)))
1323 (fn () => ())
1324
1325 | MsgDbPasswd {dbtype, passwd} =>
1326 doIt (fn () =>
1327 case Dbms.lookup dbtype of
1328 NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
1329 SOME ("Unknown database type " ^ dbtype))
1330 | SOME handler =>
1331 case #passwd handler {user = user, passwd = passwd} of
1332 NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1333 NONE)
1334 | SOME msg =>
1335 ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1336 SOME ("Error adding user: " ^ msg)))
1337 (fn () => ())
1338
1339 | MsgCreateDb {dbtype, dbname} =>
1340 doIt (fn () =>
1341 if Dbms.validDbname dbname then
1342 case Dbms.lookup dbtype of
1343 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1344 SOME ("Unknown database type " ^ dbtype))
1345 | SOME handler =>
1346 case #createdb handler {user = user, dbname = dbname} of
1347 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1348 NONE)
1349 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1350 SOME ("Error creating database: " ^ msg))
1351 else
1352 ("Invalid database name " ^ user ^ "_" ^ dbname,
1353 SOME ("Invalid database name " ^ dbname)))
1354 (fn () => ())
1355
1356 | MsgDropDb {dbtype, dbname} =>
1357 doIt (fn () =>
1358 if Dbms.validDbname dbname then
1359 case Dbms.lookup dbtype of
1360 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1361 SOME ("Unknown database type " ^ dbtype))
1362 | SOME handler =>
1363 case #dropdb handler {user = user, dbname = dbname} of
1364 NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
1365 NONE)
1366 | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1367 SOME ("Error dropping database: " ^ msg))
1368 else
1369 ("Invalid database name " ^ user ^ "_" ^ dbname,
1370 SOME ("Invalid database name " ^ dbname)))
1371 (fn () => ())
1372
1373 | MsgGrantDb {dbtype, dbname} =>
1374 doIt (fn () =>
1375 if Dbms.validDbname dbname then
1376 case Dbms.lookup dbtype of
1377 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1378 SOME ("Unknown database type " ^ dbtype))
1379 | SOME handler =>
1380 case #grant handler {user = user, dbname = dbname} of
1381 NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
1382 NONE)
1383 | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1384 SOME ("Error granting permissions to database: " ^ msg))
1385 else
1386 ("Invalid database name " ^ user ^ "_" ^ dbname,
1387 SOME ("Invalid database name " ^ dbname)))
1388 (fn () => ())
1389
1390 | MsgListMailboxes domain =>
1391 doIt (fn () =>
1392 if not (Domain.yourDomain domain) then
1393 ("User wasn't authorized to list mailboxes for " ^ domain,
1394 SOME "You're not authorized to configure that domain.")
1395 else
1396 case Vmail.list domain of
1397 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
1398 ("Sent mailbox list for " ^ domain,
1399 NONE))
1400 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
1401 SOME msg))
1402 (fn () => ())
1403
1404 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
1405 doIt (fn () =>
1406 if not (Domain.yourDomain domain) then
1407 ("User wasn't authorized to add a mailbox to " ^ domain,
1408 SOME "You're not authorized to configure that domain.")
1409 else if not (Domain.validEmailUser emailUser) then
1410 ("Invalid e-mail username " ^ emailUser,
1411 SOME "Invalid e-mail username")
1412 else if not (CharVector.all Char.isGraph passwd) then
1413 ("Invalid password",
1414 SOME "Invalid password; may only contain printable, non-space characters")
1415 else if not (Domain.yourPath mailbox) then
1416 ("User wasn't authorized to add a mailbox at " ^ mailbox,
1417 SOME ("You're not authorized to use that mailbox location. ("
1418 ^ mailbox ^ ")"))
1419 else
1420 case Vmail.add {requester = user,
1421 domain = domain, user = emailUser,
1422 passwd = passwd, mailbox = mailbox} of
1423 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
1424 NONE)
1425 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1426 SOME msg))
1427 (fn () => ())
1428
1429 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
1430 doIt (fn () =>
1431 if not (Domain.yourDomain domain) then
1432 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1433 SOME "You're not authorized to configure that domain.")
1434 else if not (Domain.validEmailUser emailUser) then
1435 ("Invalid e-mail username " ^ emailUser,
1436 SOME "Invalid e-mail username")
1437 else if not (CharVector.all Char.isGraph passwd) then
1438 ("Invalid password",
1439 SOME "Invalid password; may only contain printable, non-space characters")
1440 else
1441 case Vmail.passwd {domain = domain, user = emailUser,
1442 passwd = passwd} of
1443 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1444 NONE)
1445 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1446 SOME msg))
1447 (fn () => ())
1448
1449 | MsgRmMailbox {domain, user = emailUser} =>
1450 doIt (fn () =>
1451 if not (Domain.yourDomain domain) then
1452 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1453 SOME "You're not authorized to configure that domain.")
1454 else if not (Domain.validEmailUser emailUser) then
1455 ("Invalid e-mail username " ^ emailUser,
1456 SOME "Invalid e-mail username")
1457 else
1458 case Vmail.rm {domain = domain, user = emailUser} of
1459 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
1460 NONE)
1461 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1462 SOME msg))
1463 (fn () => ())
1464
1465 | MsgSaQuery addr =>
1466 doIt (fn () =>
1467 case checkAddr addr of
1468 NONE => ("User tried to query SA filtering for " ^ addr,
1469 SOME "You aren't allowed to configure SA filtering for that recipient.")
1470 | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
1471 ("Queried SA filtering status for " ^ addr,
1472 NONE)))
1473 (fn () => ())
1474
1475 | MsgSaSet (addr, b) =>
1476 doIt (fn () =>
1477 case checkAddr addr of
1478 NONE => ("User tried to set SA filtering for " ^ addr,
1479 SOME "You aren't allowed to configure SA filtering for that recipient.")
1480 | SOME addr' => (SetSA.set (addr', b);
1481 Msg.send (bio, MsgOk);
1482 ("Set SA filtering status for " ^ addr ^ " to "
1483 ^ (if b then "ON" else "OFF"),
1484 NONE)))
1485 (fn () => ())
1486
1487 | MsgSmtpLogReq domain =>
1488 doIt (fn () =>
1489 if not (Domain.yourDomain domain) then
1490 ("Unauthorized user tried to request SMTP logs for " ^ domain,
1491 SOME "You aren't authorized to configure that domain.")
1492 else
1493 (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1494 domain;
1495 ("Requested SMTP logs for " ^ domain,
1496 NONE)))
1497 (fn () => ())
1498
1499 | MsgQuery q =>
1500 doIt (fn () => (Msg.send (bio, answerQuery q);
1501 (describeQuery q,
1502 NONE)))
1503 (fn () => ())
1504
1505 | MsgMysqlFixperms =>
1506 doIt (fn () => if OS.Process.isSuccess
1507 (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
1508 ("Requested mysql-fixperms",
1509 NONE)
1510 else
1511 ("Requested mysql-fixperms, but execution failed!",
1512 SOME "Script execution failed."))
1513 (fn () => ())
1514
1515 | MsgDescribe dom =>
1516 doIt (fn () => if not (Domain.validDomain dom) then
1517 ("Requested description of invalid domain " ^ dom,
1518 SOME "Invalid domain name")
1519 else if not (Domain.yourDomain dom
1520 orelse Acl.query {user = user, class = "priv", value = "all"}) then
1521 ("Requested description of " ^ dom ^ ", but not allowed access",
1522 SOME "Access denied")
1523 else
1524 (Msg.send (bio, MsgDescription (Domain.describe dom));
1525 ("Sent description of domain " ^ dom,
1526 NONE)))
1527 (fn () => ())
1528
1529 | _ =>
1530 doIt (fn () => ("Unexpected command",
1531 SOME "Unexpected command"))
1532 (fn () => ())
1533 in
1534 cmdLoop ()
1535 end
1536 handle e as (OpenSSL.OpenSSL s) =>
1537 (print ("OpenSSL error: " ^ s ^ "\n");
1538 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1539 OpenSSL.close bio
1540 handle OpenSSL.OpenSSL _ => ();
1541 loop ())
1542 | OS.SysErr (s, _) =>
1543 (print ("System error: " ^ s ^ "\n");
1544 OpenSSL.close bio
1545 handle OpenSSL.OpenSSL _ => ();
1546 loop ())
1547 | IO.Io {name, function, cause} =>
1548 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1549 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1550 OpenSSL.close bio
1551 handle OpenSSL.OpenSSL _ => ();
1552 loop ())
1553 | OS.Path.InvalidArc =>
1554 (print "Invalid arc\n";
1555 OpenSSL.close bio
1556 handle OpenSSL.OpenSSL _ => ();
1557 loop ())
1558 | e =>
1559 (print "Unknown exception in main loop!\n";
1560 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1561 OpenSSL.close bio
1562 handle OpenSSL.OpenSSL _ => ();
1563 loop ()))
1564 handle e as (OpenSSL.OpenSSL s) =>
1565 (print ("OpenSSL error: " ^ s ^ "\n");
1566 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1567 loop ())
1568 | OS.SysErr (s, _) =>
1569 (print ("System error: " ^ s ^ "\n");
1570 loop ())
1571 | IO.Io {name, function, cause} =>
1572 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1573 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1574 loop ())
1575 | e =>
1576 (print "Unknown exception in main loop!\n";
1577 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1578 loop ())
1579 in
1580 print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
1581 print "Listening for connections....\n";
1582 loop ();
1583 OpenSSL.shutdown sock
1584 end
1585
1586 fun slave () =
1587 let
1588 val host = Slave.hostname ()
1589
1590 val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1591 Config.keyDir ^ "/" ^ host ^ "/key.pem",
1592 Config.trustStore)
1593
1594 val sock = OpenSSL.listen (context, Config.slavePort)
1595
1596 val _ = print ("Slave server starting at " ^ now () ^ "\n")
1597
1598 fun loop () =
1599 case OpenSSL.accept sock of
1600 NONE => ()
1601 | SOME bio =>
1602 let
1603 val peer = OpenSSL.peerCN bio
1604 val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
1605 in
1606 if peer = Config.dispatcherName then let
1607 fun loop' files =
1608 case Msg.recv bio of
1609 NONE => print "Dispatcher closed connection unexpectedly\n"
1610 | SOME m =>
1611 case m of
1612 MsgFile file => loop' (file :: files)
1613 | MsgDoFiles => (Slave.handleChanges files;
1614 Msg.send (bio, MsgOk))
1615 | MsgRegenerate => (Domain.resetLocal ();
1616 Msg.send (bio, MsgOk))
1617 | _ => (print "Dispatcher sent unexpected command\n";
1618 Msg.send (bio, MsgError "Unexpected command"))
1619 in
1620 loop' [];
1621 ignore (OpenSSL.readChar bio);
1622 OpenSSL.close bio;
1623 loop ()
1624 end
1625 else if peer = "domtool" then
1626 case Msg.recv bio of
1627 SOME MsgShutdown => (OpenSSL.close bio;
1628 print ("Shutting down at " ^ now () ^ "\n\n"))
1629 | _ => (OpenSSL.close bio;
1630 loop ())
1631 else
1632 case Msg.recv bio of
1633 SOME (MsgQuery q) => (print (describeQuery q ^ "\n");
1634 Msg.send (bio, answerQuery q);
1635 ignore (OpenSSL.readChar bio);
1636 OpenSSL.close bio;
1637 loop ())
1638 | _ => (OpenSSL.close bio;
1639 loop ())
1640 end handle OpenSSL.OpenSSL s =>
1641 (print ("OpenSSL error: " ^ s ^ "\n");
1642 OpenSSL.close bio
1643 handle OpenSSL.OpenSSL _ => ();
1644 loop ())
1645 | e as OS.SysErr (s, _) =>
1646 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1647 print ("System error: "^ s ^ "\n");
1648 OpenSSL.close bio
1649 handle OpenSSL.OpenSSL _ => ();
1650 loop ())
1651 | IO.Io {function, name, ...} =>
1652 (print ("IO error: " ^ function ^ ": " ^ name ^ "\n");
1653 OpenSSL.close bio
1654 handle OpenSSL.OpenSSL _ => ();
1655 loop ())
1656 | e =>
1657 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1658 print "Uncaught exception!\n";
1659 OpenSSL.close bio
1660 handle OpenSSL.OpenSSL _ => ();
1661 loop ())
1662 in
1663 loop ();
1664 OpenSSL.shutdown sock
1665 end
1666
1667 fun listBasis () =
1668 let
1669 val dir = Posix.FileSys.opendir Config.libRoot
1670
1671 fun loop files =
1672 case Posix.FileSys.readdir dir of
1673 NONE => (Posix.FileSys.closedir dir;
1674 files)
1675 | SOME fname =>
1676 if String.isSuffix ".dtl" fname then
1677 loop (OS.Path.joinDirFile {dir = Config.libRoot,
1678 file = fname}
1679 :: files)
1680 else
1681 loop files
1682 in
1683 loop []
1684 end
1685
1686 fun autodocBasis outdir =
1687 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1688
1689 end