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