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