c95ef31f9bef5588782a3fda58730b864d7c6415
[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 fun requestFirewallRegen node =
958 let
959 val (user, context) = requestContext (fn () => ())
960 val bio = OpenSSL.connect true (context, Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
961 (* Only supporting on slave nodes *)
962
963 val _ = Msg.send (bio, MsgFirewallRegen)
964
965 fun handleResult () =
966 case Msg.recv bio of
967 NONE => (print "Server closed connection unexpectedly.\n";
968 OS.Process.failure)
969 | SOME m =>
970 case m of
971 MsgOk => (print "Firewall regenerated.\n";
972 OS.Process.success)
973 | MsgError s => (print ("Firewall regeneration failed: " ^ s ^ "\n");
974 OS.Process.failure)
975 | _ => (print "Unexpected server reply.\n";
976 OS.Process.failure)
977 in
978 handleResult()
979 before OpenSSL.close bio
980 end
981
982 structure SS = StringSet
983
984 fun domainList dname =
985 let
986 val dir = Posix.FileSys.opendir dname
987
988 fun visitNode dset =
989 case Posix.FileSys.readdir dir of
990 NONE => dset
991 | SOME node =>
992 let
993 val path = OS.Path.joinDirFile {dir = dname,
994 file = node}
995
996 fun visitDomains (path, bfor, dset) =
997 let
998 val dir = Posix.FileSys.opendir path
999
1000 fun loop dset =
1001 case Posix.FileSys.readdir dir of
1002 NONE => dset
1003 | SOME dname =>
1004 let
1005 val path = OS.Path.joinDirFile {dir = path,
1006 file = dname}
1007 in
1008 if Posix.FileSys.ST.isDir (Posix.FileSys.stat path) then
1009 let
1010 val bfor = dname :: bfor
1011 in
1012 loop (visitDomains (path, bfor,
1013 SS.add (dset,
1014 String.concatWith "." bfor)))
1015 end
1016 else
1017 loop dset
1018 end
1019 in
1020 loop dset
1021 before Posix.FileSys.closedir dir
1022 end
1023 in
1024 visitNode (visitDomains (path, [], dset))
1025 end
1026 in
1027 visitNode SS.empty
1028 before Posix.FileSys.closedir dir
1029 end
1030
1031 fun regenerateEither tc checker context =
1032 let
1033 val () = print "Starting regeneration....\n"
1034
1035 val domainsBefore =
1036 if tc then
1037 SS.empty
1038 else
1039 domainList Config.resultRoot
1040
1041 fun ifReal f =
1042 if tc then
1043 ()
1044 else
1045 f ()
1046
1047 val _ = ErrorMsg.reset ()
1048
1049 val b = basis ()
1050 val () = Tycheck.disallowExterns ()
1051
1052 val () = ifReal (fn () =>
1053 (ignore (OS.Process.system ("rm -rf " ^ Config.oldResultRoot ^ "/*"));
1054 ignore (OS.Process.system ("cp -r " ^ Config.resultRoot
1055 ^ "/* " ^ Config.oldResultRoot ^ "/"));
1056 Domain.resetGlobal ()))
1057
1058 val ok = ref true
1059
1060 fun contactNode (node, ip) =
1061 if node = Config.defaultNode then
1062 Domain.resetLocal ()
1063 else let
1064 val bio = OpenSSL.connect true (context,
1065 ip
1066 ^ ":"
1067 ^ Int.toString Config.slavePort)
1068 in
1069 Msg.send (bio, MsgRegenerate);
1070 case Msg.recv bio of
1071 NONE => print "Slave closed connection unexpectedly\n"
1072 | SOME m =>
1073 case m of
1074 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
1075 | MsgError s => print ("Slave " ^ node
1076 ^ " returned error: " ^
1077 s ^ "\n")
1078 | _ => print ("Slave " ^ node
1079 ^ " returned unexpected command\n");
1080 OpenSSL.close bio
1081 end
1082 handle OpenSSL.OpenSSL s => print ("OpenSSL error: " ^ s ^ "\n")
1083
1084 fun doUser user =
1085 let
1086 val _ = Domain.setUser user
1087 val _ = ErrorMsg.reset ()
1088
1089 val dname = Config.domtoolDir user
1090 in
1091 if Posix.FileSys.access (dname, []) then
1092 let
1093 val dir = Posix.FileSys.opendir dname
1094
1095 fun loop files =
1096 case Posix.FileSys.readdir dir of
1097 NONE => (Posix.FileSys.closedir dir;
1098 files)
1099 | SOME fname =>
1100 if notTmp fname then
1101 loop (OS.Path.joinDirFile {dir = dname,
1102 file = fname}
1103 :: files)
1104 else
1105 loop files
1106
1107 val files = loop []
1108 val (_, files) = Order.order (SOME b) files
1109
1110 fun checker' (file, (G, evs)) =
1111 checker G evs file
1112 in
1113 if !ErrorMsg.anyErrors then
1114 (ErrorMsg.reset ();
1115 print ("User " ^ user ^ "'s configuration has errors!\n");
1116 ok := false)
1117 else
1118 ();
1119 ignore (foldl checker' (basis (), Defaults.eInit ()) files)
1120 end
1121 else if String.isSuffix "_admin" user then
1122 ()
1123 else
1124 (print ("Couldn't access " ^ user ^ "'s ~/.domtool directory.\n");
1125 ok := false)
1126 end
1127 handle IO.Io {name, function, ...} =>
1128 (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");
1129 ok := false)
1130 | exn as OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
1131 ok := false)
1132 | ErrorMsg.Error => (ErrorMsg.reset ();
1133 print ("User " ^ user ^ " had a compilation error.\n");
1134 ok := false)
1135 | _ => (print "Unknown exception during regeneration!\n";
1136 ok := false)
1137 in
1138 ifReal (fn () => (app contactNode Config.nodeIps;
1139 Env.pre ()));
1140 app doUser (Acl.users ());
1141 ifReal (fn () =>
1142 let
1143 val domainsAfter = domainList Config.resultRoot
1144 val domainsGone = SS.difference (domainsBefore, domainsAfter)
1145 in
1146 if SS.isEmpty domainsGone then
1147 ()
1148 else
1149 (print "Domains to kill:";
1150 SS.app (fn s => (print " "; print s)) domainsGone;
1151 print "\n";
1152
1153 Domain.rmdom' Config.oldResultRoot (SS.listItems domainsGone));
1154
1155 Env.post ()
1156 end);
1157 !ok
1158 end
1159
1160 val regenerate = regenerateEither false eval
1161 val regenerateTc = regenerateEither true
1162 (fn G => fn evs => fn file =>
1163 (#1 (check G file), evs))
1164
1165 fun usersChanged () =
1166 (Domain.onUsersChange ();
1167 ignore (OS.Process.system Config.publish_reusers))
1168
1169 fun rmuser user =
1170 let
1171 val doms = Acl.class {user = user, class = "domain"}
1172 val doms = List.filter (fn dom =>
1173 case Acl.whoHas {class = "domain", value = dom} of
1174 [_] => true
1175 | _ => false) (StringSet.listItems doms)
1176 in
1177 Acl.rmuser user;
1178 Domain.rmdom doms;
1179 usersChanged ()
1180 end
1181
1182 fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
1183
1184 fun answerQuery q =
1185 case q of
1186 QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
1187 | QCron user => if Cron.allowed user then MsgYes else MsgNo
1188 | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
1189 | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
1190 | QSocket user => MsgSocket (SocketPerm.query user)
1191 | QFirewall user => MsgFirewall (Firewall.query user)
1192
1193 fun describeQuery q =
1194 case q of
1195 QApt pkg => "Requested installation status of package " ^ pkg
1196 | QCron user => "Asked about cron permissions for user " ^ user
1197 | QFtp user => "Asked about FTP permissions for user " ^ user
1198 | QTrustedPath user => "Asked about trusted path settings for user " ^ user
1199 | QSocket user => "Asked about socket permissions for user " ^ user
1200 | QFirewall user => "Asked about firewall rules for user " ^ user
1201
1202 fun doIt' loop bio f cleanup =
1203 ((case f () of
1204 (msgLocal, SOME msgRemote) =>
1205 (print msgLocal;
1206 print "\n";
1207 Msg.send (bio, MsgError msgRemote))
1208 | (msgLocal, NONE) =>
1209 (print msgLocal;
1210 print "\n";
1211 Msg.send (bio, MsgOk)))
1212 handle e as (OpenSSL.OpenSSL s) =>
1213 (print ("OpenSSL error: " ^ s ^ "\n");
1214 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1215 Msg.send (bio, MsgError ("OpenSSL error: " ^ s))
1216 handle OpenSSL.OpenSSL _ => ())
1217 | OS.SysErr (s, _) =>
1218 (print "System error: ";
1219 print s;
1220 print "\n";
1221 Msg.send (bio, MsgError ("System error: " ^ s))
1222 handle OpenSSL.OpenSSL _ => ())
1223 | Fail s =>
1224 (print "Failure: ";
1225 print s;
1226 print "\n";
1227 Msg.send (bio, MsgError ("Failure: " ^ s))
1228 handle OpenSSL.OpenSSL _ => ())
1229 | ErrorMsg.Error =>
1230 (print "Compilation error\n";
1231 Msg.send (bio, MsgError "Error during configuration evaluation")
1232 handle OpenSSL.OpenSSL _ => ());
1233 (cleanup ();
1234 ignore (OpenSSL.readChar bio);
1235 OpenSSL.close bio)
1236 handle OpenSSL.OpenSSL _ => ();
1237 loop ())
1238
1239 fun service () =
1240 let
1241 val host = Slave.hostname ()
1242
1243 val () = Acl.read Config.aclFile
1244
1245 val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1246 Config.keyDir ^ "/" ^ host ^ "/key.pem",
1247 Config.trustStore)
1248 val _ = Domain.set_context context
1249
1250 val sock = OpenSSL.listen (context, Config.dispatcherPort)
1251
1252 fun loop () =
1253 (case OpenSSL.accept sock of
1254 NONE => ()
1255 | SOME bio =>
1256 let
1257 val user = OpenSSL.peerCN bio
1258 val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
1259 val () = Domain.setUser user
1260 val doIt = doIt' loop bio
1261
1262 fun doConfig codes =
1263 let
1264 val _ = print "Configuration:\n"
1265 val _ = app (fn s => (print s; print "\n")) codes
1266 val _ = print "\n"
1267
1268 val outname = OS.FileSys.tmpName ()
1269
1270 fun doOne (code, (G, evs)) =
1271 let
1272 val outf = TextIO.openOut outname
1273 in
1274 TextIO.output (outf, code);
1275 TextIO.closeOut outf;
1276 eval G evs outname
1277 end
1278 in
1279 doIt (fn () => (Env.pre ();
1280 ignore (foldl doOne (basis (), Defaults.eInit ()) codes);
1281 Env.post ();
1282 Msg.send (bio, MsgOk);
1283 ("Configuration complete.", NONE)))
1284 (fn () => OS.FileSys.remove outname)
1285 end
1286
1287 fun checkAddr s =
1288 case String.fields (fn ch => ch = #"@") s of
1289 [user'] =>
1290 if user = user' then
1291 SOME (SetSA.User s)
1292 else
1293 NONE
1294 | [user', domain] =>
1295 if Domain.validEmailUser user' andalso Domain.yourDomain domain then
1296 SOME (SetSA.Email s)
1297 else
1298 NONE
1299 | _ => NONE
1300
1301 fun cmdLoop () =
1302 case Msg.recv bio of
1303 NONE => (OpenSSL.close bio
1304 handle OpenSSL.OpenSSL _ => ();
1305 loop ())
1306 | SOME m =>
1307 case m of
1308 MsgConfig code => doConfig [code]
1309 | MsgMultiConfig codes => doConfig codes
1310
1311 | MsgShutdown =>
1312 if Acl.query {user = user, class = "priv", value = "all"}
1313 orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
1314 print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")
1315 else
1316 (print "Unauthorized shutdown command!\n";
1317 OpenSSL.close bio
1318 handle OpenSSL.OpenSSL _ => ();
1319 loop ())
1320
1321 | MsgGrant acl =>
1322 doIt (fn () =>
1323 if Acl.query {user = user, class = "priv", value = "all"} then
1324 (Acl.grant acl;
1325 Acl.write Config.aclFile;
1326 if #class acl = "user" then
1327 usersChanged ()
1328 else
1329 ();
1330 ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
1331 NONE))
1332 else
1333 ("Unauthorized user asked to grant a permission!",
1334 SOME "Not authorized to grant privileges"))
1335 (fn () => ())
1336
1337 | MsgRevoke acl =>
1338 doIt (fn () =>
1339 if Acl.query {user = user, class = "priv", value = "all"} then
1340 (Acl.revoke acl;
1341 Acl.write Config.aclFile;
1342 ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
1343 NONE))
1344 else
1345 ("Unauthorized user asked to revoke a permission!",
1346 SOME "Not authorized to revoke privileges"))
1347 (fn () => ())
1348
1349 | MsgListPerms user =>
1350 doIt (fn () =>
1351 (Msg.send (bio, MsgPerms (Acl.queryAll user));
1352 ("Sent permission list for user " ^ user ^ ".",
1353 NONE)))
1354 (fn () => ())
1355
1356 | MsgWhoHas perm =>
1357 doIt (fn () =>
1358 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
1359 ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
1360 NONE)))
1361 (fn () => ())
1362
1363 | MsgRmdom doms =>
1364 doIt (fn () =>
1365 if Acl.query {user = user, class = "priv", value = "all"}
1366 orelse List.all (fn dom => Domain.validDomain dom
1367 andalso Acl.queryDomain {user = user, domain = dom}) doms then
1368 (Domain.rmdom doms;
1369 (*app (fn dom =>
1370 Acl.revokeFromAll {class = "domain", value = dom}) doms;
1371 Acl.write Config.aclFile;*)
1372 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
1373 NONE))
1374 else
1375 ("Unauthorized user asked to remove a domain!",
1376 SOME "Not authorized to remove that domain"))
1377 (fn () => ())
1378
1379 | MsgRegenerate =>
1380 doIt (fn () =>
1381 if Acl.query {user = user, class = "priv", value = "regen"}
1382 orelse Acl.query {user = user, class = "priv", value = "all"} then
1383 (if regenerate context then
1384 ("Regenerated all configuration.",
1385 NONE)
1386 else
1387 ("Error regenerating configuration!",
1388 SOME "Error regenerating configuration! Consult /var/log/domtool.log."))
1389 else
1390 ("Unauthorized user asked to regenerate!",
1391 SOME "Not authorized to regenerate"))
1392 (fn () => ())
1393
1394 | MsgRegenerateTc =>
1395 doIt (fn () =>
1396 if Acl.query {user = user, class = "priv", value = "regen"}
1397 orelse Acl.query {user = user, class = "priv", value = "all"} then
1398 (if regenerateTc context then
1399 ("Checked all configuration.",
1400 NONE)
1401 else
1402 ("Found a compilation error!",
1403 SOME "Found a compilation error! Consult /var/log/domtool.log."))
1404 else
1405 ("Unauthorized user asked to regenerate -tc!",
1406 SOME "Not authorized to regenerate -tc"))
1407 (fn () => ())
1408
1409 | MsgRmuser user' =>
1410 doIt (fn () =>
1411 if Acl.query {user = user, class = "priv", value = "all"} then
1412 (rmuser user';
1413 Acl.write Config.aclFile;
1414 ("Removed user " ^ user' ^ ".",
1415 NONE))
1416 else
1417 ("Unauthorized user asked to remove a user!",
1418 SOME "Not authorized to remove users"))
1419 (fn () => ())
1420
1421 | MsgListMailboxes domain =>
1422 doIt (fn () =>
1423 if not (Domain.yourDomain domain) then
1424 ("User wasn't authorized to list mailboxes for " ^ domain,
1425 SOME "You're not authorized to configure that domain.")
1426 else
1427 case Vmail.list domain of
1428 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
1429 ("Sent mailbox list for " ^ domain,
1430 NONE))
1431 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
1432 SOME msg))
1433 (fn () => ())
1434
1435 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
1436 doIt (fn () =>
1437 if not (Domain.yourDomain domain) then
1438 ("User wasn't authorized to add a mailbox to " ^ 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 if not (Domain.yourPath mailbox) then
1447 ("User wasn't authorized to add a mailbox at " ^ mailbox,
1448 SOME ("You're not authorized to use that mailbox location. ("
1449 ^ mailbox ^ ")"))
1450 else
1451 case Vmail.add {requester = user,
1452 domain = domain, user = emailUser,
1453 passwd = passwd, mailbox = mailbox} of
1454 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
1455 NONE)
1456 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1457 SOME msg))
1458 (fn () => ())
1459
1460 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
1461 doIt (fn () =>
1462 if not (Domain.yourDomain domain) then
1463 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1464 SOME "You're not authorized to configure that domain.")
1465 else if not (Domain.validEmailUser emailUser) then
1466 ("Invalid e-mail username " ^ emailUser,
1467 SOME "Invalid e-mail username")
1468 else if not (CharVector.all Char.isGraph passwd) then
1469 ("Invalid password",
1470 SOME "Invalid password; may only contain printable, non-space characters")
1471 else
1472 case Vmail.passwd {domain = domain, user = emailUser,
1473 passwd = passwd} of
1474 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1475 NONE)
1476 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1477 SOME msg))
1478 (fn () => ())
1479
1480 | MsgRmMailbox {domain, user = emailUser} =>
1481 doIt (fn () =>
1482 if not (Domain.yourDomain domain) then
1483 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1484 SOME "You're not authorized to configure that domain.")
1485 else if not (Domain.validEmailUser emailUser) then
1486 ("Invalid e-mail username " ^ emailUser,
1487 SOME "Invalid e-mail username")
1488 else
1489 case Vmail.rm {domain = domain, user = emailUser} of
1490 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
1491 NONE)
1492 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1493 SOME msg))
1494 (fn () => ())
1495
1496 | MsgSaQuery addr =>
1497 doIt (fn () =>
1498 case checkAddr addr of
1499 NONE => ("User tried to query SA filtering for " ^ addr,
1500 SOME "You aren't allowed to configure SA filtering for that recipient.")
1501 | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
1502 ("Queried SA filtering status for " ^ addr,
1503 NONE)))
1504 (fn () => ())
1505
1506 | MsgSaSet (addr, b) =>
1507 doIt (fn () =>
1508 case checkAddr addr of
1509 NONE => ("User tried to set SA filtering for " ^ addr,
1510 SOME "You aren't allowed to configure SA filtering for that recipient.")
1511 | SOME addr' => (SetSA.set (addr', b);
1512 Msg.send (bio, MsgOk);
1513 ("Set SA filtering status for " ^ addr ^ " to "
1514 ^ (if b then "ON" else "OFF"),
1515 NONE)))
1516 (fn () => ())
1517
1518 | MsgSmtpLogReq domain =>
1519 doIt (fn () =>
1520 if not (Domain.yourDomain domain) then
1521 ("Unauthorized user tried to request SMTP logs for " ^ domain,
1522 SOME "You aren't authorized to configure that domain.")
1523 else
1524 (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1525 domain;
1526 ("Requested SMTP logs for " ^ domain,
1527 NONE)))
1528 (fn () => ())
1529
1530 | MsgQuery q =>
1531 doIt (fn () => (Msg.send (bio, answerQuery q);
1532 (describeQuery q,
1533 NONE)))
1534 (fn () => ())
1535 | MsgDescribe dom =>
1536 doIt (fn () => if not (Domain.validDomain dom) then
1537 ("Requested description of invalid domain " ^ dom,
1538 SOME "Invalid domain name")
1539 else if not (Domain.yourDomain dom
1540 orelse Acl.query {user = user, class = "priv", value = "all"}) then
1541 ("Requested description of " ^ dom ^ ", but not allowed access",
1542 SOME "Access denied")
1543 else
1544 (Msg.send (bio, MsgDescription (Domain.describe dom));
1545 ("Sent description of domain " ^ dom,
1546 NONE)))
1547 (fn () => ())
1548
1549 | MsgReUsers =>
1550 doIt (fn () => if Acl.query {user = user, class = "priv", value = "regen"}
1551 orelse Acl.query {user = user, class = "priv", value = "all"} then
1552 (usersChanged ();
1553 ("Users change callbacks run", NONE))
1554 else
1555 ("Unauthorized user asked to reusers!",
1556 SOME "You aren't authorized to regenerate files."))
1557 (fn () => ())
1558
1559 | _ =>
1560 doIt (fn () => ("Unexpected command",
1561 SOME "Unexpected command"))
1562 (fn () => ())
1563 in
1564 cmdLoop ()
1565 end
1566 handle e as (OpenSSL.OpenSSL s) =>
1567 (print ("OpenSSL error: " ^ s ^ "\n");
1568 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1569 OpenSSL.close bio
1570 handle OpenSSL.OpenSSL _ => ();
1571 loop ())
1572 | OS.SysErr (s, _) =>
1573 (print ("System error: " ^ s ^ "\n");
1574 OpenSSL.close bio
1575 handle OpenSSL.OpenSSL _ => ();
1576 loop ())
1577 | IO.Io {name, function, cause} =>
1578 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1579 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1580 OpenSSL.close bio
1581 handle OpenSSL.OpenSSL _ => ();
1582 loop ())
1583 | OS.Path.InvalidArc =>
1584 (print "Invalid arc\n";
1585 OpenSSL.close bio
1586 handle OpenSSL.OpenSSL _ => ();
1587 loop ())
1588 | e =>
1589 (print "Unknown exception in main loop!\n";
1590 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1591 OpenSSL.close bio
1592 handle OpenSSL.OpenSSL _ => ();
1593 loop ()))
1594 handle e as (OpenSSL.OpenSSL s) =>
1595 (print ("OpenSSL error: " ^ s ^ "\n");
1596 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1597 loop ())
1598 | OS.SysErr (s, _) =>
1599 (print ("System error: " ^ s ^ "\n");
1600 loop ())
1601 | IO.Io {name, function, cause} =>
1602 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1603 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1604 loop ())
1605 | e =>
1606 (print "Unknown exception in main loop!\n";
1607 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1608 loop ())
1609 in
1610 print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
1611 print "Listening for connections....\n";
1612 loop ();
1613 OpenSSL.shutdown sock
1614 end
1615
1616 fun slave () =
1617 let
1618 val host = Slave.hostname ()
1619
1620 val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1621 Config.keyDir ^ "/" ^ host ^ "/key.pem",
1622 Config.trustStore)
1623
1624 val sock = OpenSSL.listen (context, Config.slavePort)
1625
1626 val _ = print ("Slave server starting at " ^ now () ^ "\n")
1627
1628 fun loop () =
1629 (case OpenSSL.accept sock of
1630 NONE => ()
1631 | SOME bio =>
1632 let
1633 val peer = OpenSSL.peerCN bio
1634 val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
1635 in
1636 if peer = Config.dispatcherName then let
1637 fun loop' files =
1638 case Msg.recv bio of
1639 NONE => print "Dispatcher closed connection unexpectedly\n"
1640 | SOME m =>
1641 case m of
1642 MsgFile file => loop' (file :: files)
1643 | MsgDoFiles => (Slave.handleChanges files;
1644 Msg.send (bio, MsgOk))
1645 | MsgRegenerate => (Domain.resetLocal ();
1646 Msg.send (bio, MsgOk))
1647 | MsgVmailChanged => (if Vmail.doChanged () then
1648 Msg.send (bio, MsgOk)
1649 else
1650 Msg.send (bio, MsgError "userdb update failed"))
1651 | _ => (print "Dispatcher sent unexpected command\n";
1652 Msg.send (bio, MsgError "Unexpected command"))
1653 in
1654 loop' [];
1655 ignore (OpenSSL.readChar bio);
1656 OpenSSL.close bio;
1657 loop ()
1658 end
1659 else if peer = "domtool" then
1660 case Msg.recv bio of
1661 SOME MsgShutdown => (OpenSSL.close bio;
1662 print ("Shutting down at " ^ now () ^ "\n\n"))
1663 | _ => (OpenSSL.close bio;
1664 loop ())
1665 else
1666 let
1667 val doIt = doIt' loop bio
1668 val user = peer
1669 in
1670 case Msg.recv bio of
1671 NONE => (OpenSSL.close bio
1672 handle OpenSSL.OpenSSL _ => ();
1673 loop ())
1674 | SOME m =>
1675 case m of
1676 (MsgQuery q) => (print (describeQuery q ^ "\n");
1677 Msg.send (bio, answerQuery q);
1678 ignore (OpenSSL.readChar bio);
1679 OpenSSL.close bio;
1680 loop ())
1681 | MsgCreateDbUser {dbtype, passwd} =>
1682 doIt (fn () =>
1683 case Dbms.lookup dbtype of
1684 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
1685 SOME ("Unknown database type " ^ dbtype))
1686 | SOME handler =>
1687 case #adduser handler {user = user, passwd = passwd} of
1688 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
1689 NONE)
1690 | SOME msg =>
1691 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
1692 SOME ("Error adding user: " ^ msg)))
1693 (fn () => ())
1694
1695 | MsgDbPasswd {dbtype, passwd} =>
1696 doIt (fn () =>
1697 case Dbms.lookup dbtype of
1698 NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
1699 SOME ("Unknown database type " ^ dbtype))
1700 | SOME handler =>
1701 case #passwd handler {user = user, passwd = passwd} of
1702 NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1703 NONE)
1704 | SOME msg =>
1705 ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1706 SOME ("Error adding user: " ^ msg)))
1707 (fn () => ())
1708
1709 | MsgCreateDb {dbtype, dbname, encoding} =>
1710 doIt (fn () =>
1711 if Dbms.validDbname dbname then
1712 case Dbms.lookup dbtype of
1713 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1714 SOME ("Unknown database type " ^ dbtype))
1715 | SOME handler =>
1716 if not (Dbms.validEncoding encoding) then
1717 ("Invalid encoding " ^ valOf encoding ^ " requested for database creation.",
1718 SOME "Invalid encoding")
1719 else
1720 case #createdb handler {user = user, dbname = dbname, encoding = encoding} of
1721 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1722 NONE)
1723 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1724 SOME ("Error creating database: " ^ msg))
1725 else
1726 ("Invalid database name " ^ user ^ "_" ^ dbname,
1727 SOME ("Invalid database name " ^ dbname)))
1728 (fn () => ())
1729
1730 | MsgDropDb {dbtype, dbname} =>
1731 doIt (fn () =>
1732 if Dbms.validDbname dbname then
1733 case Dbms.lookup dbtype of
1734 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1735 SOME ("Unknown database type " ^ dbtype))
1736 | SOME handler =>
1737 case #dropdb handler {user = user, dbname = dbname} of
1738 NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
1739 NONE)
1740 | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1741 SOME ("Error dropping database: " ^ msg))
1742 else
1743 ("Invalid database name " ^ user ^ "_" ^ dbname,
1744 SOME ("Invalid database name " ^ dbname)))
1745 (fn () => ())
1746
1747 | MsgGrantDb {dbtype, dbname} =>
1748 doIt (fn () =>
1749 if Dbms.validDbname dbname then
1750 case Dbms.lookup dbtype of
1751 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1752 SOME ("Unknown database type " ^ dbtype))
1753 | SOME handler =>
1754 case #grant handler {user = user, dbname = dbname} of
1755 NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
1756 NONE)
1757 | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1758 SOME ("Error granting permissions to database: " ^ msg))
1759 else
1760 ("Invalid database name " ^ user ^ "_" ^ dbname,
1761 SOME ("Invalid database name " ^ dbname)))
1762 (fn () => ())
1763 | MsgMysqlFixperms =>
1764 (print "Starting mysql-fixperms\n";
1765 doIt (fn () => if OS.Process.isSuccess
1766 (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
1767 ("Requested mysql-fixperms",
1768 NONE)
1769 else
1770 ("Requested mysql-fixperms, but execution failed!",
1771 SOME "Script execution failed."))
1772 (fn () => ()))
1773 | MsgFirewallRegen =>
1774 doIt (fn () => if Acl.query {user = user, class = "priv", value = "all"} andalso List.exists (fn x => x = host) Config.Firewall.firewallNodes then
1775 if (Firewall.generateFirewallConfig (Firewall.parseRules ()) andalso Firewall.publishConfig ())
1776 then
1777 ("Firewall rules regenerated.", NONE)
1778 else
1779 ("Rules regeneration failed!", SOME "Script execution failed.")
1780 else
1781 ("Not authorized to regenerate firewall.", SOME ("Unauthorized user " ^ user ^ "attempted to regenerated firewall")))
1782 (fn () => ())
1783
1784 | _ => (OpenSSL.close bio;
1785 loop ())
1786 end
1787 end handle OpenSSL.OpenSSL s =>
1788 (print ("OpenSSL error: " ^ s ^ "\n");
1789 OpenSSL.close bio
1790 handle OpenSSL.OpenSSL _ => ();
1791 loop ())
1792 | e as OS.SysErr (s, _) =>
1793 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1794 print ("System error: "^ s ^ "\n");
1795 OpenSSL.close bio
1796 handle OpenSSL.OpenSSL _ => ();
1797 loop ())
1798 | IO.Io {function, name, ...} =>
1799 (print ("IO error: " ^ function ^ ": " ^ name ^ "\n");
1800 OpenSSL.close bio
1801 handle OpenSSL.OpenSSL _ => ();
1802 loop ())
1803 | e =>
1804 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1805 print "Uncaught exception!\n";
1806 OpenSSL.close bio
1807 handle OpenSSL.OpenSSL _ => ();
1808 loop ()))
1809 handle OpenSSL.OpenSSL s =>
1810 (print ("OpenSSL error: " ^ s ^ "\n");
1811 loop ())
1812 | e =>
1813 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1814 print "Uncaught exception!\n";
1815 loop ())
1816 in
1817 loop ();
1818 OpenSSL.shutdown sock
1819 end
1820
1821 fun listBasis () =
1822 let
1823 val dir = Posix.FileSys.opendir Config.libRoot
1824
1825 fun loop files =
1826 case Posix.FileSys.readdir dir of
1827 NONE => (Posix.FileSys.closedir dir;
1828 files)
1829 | SOME fname =>
1830 if String.isSuffix ".dtl" fname then
1831 loop (OS.Path.joinDirFile {dir = Config.libRoot,
1832 file = fname}
1833 :: files)
1834 else
1835 loop files
1836 in
1837 loop []
1838 end
1839
1840 fun autodocBasis outdir =
1841 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1842
1843 end