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