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