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