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