8cc5a3addf6c339804f8ec21309b3a7b873f4cd3
[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 => raise ErrorMsg.Error
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 => raise ErrorMsg.Error
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 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 fun regenerateEither tc checker context =
892 let
893 fun ifReal f =
894 if tc then
895 ()
896 else
897 f ()
898
899 val _ = ErrorMsg.reset ()
900
901 val b = basis ()
902 val () = Tycheck.disallowExterns ()
903
904 val () = ifReal Domain.resetGlobal
905
906 val ok = ref true
907
908 fun contactNode (node, ip) =
909 if node = Config.defaultNode then
910 Domain.resetLocal ()
911 else let
912 val bio = OpenSSL.connect (context,
913 ip
914 ^ ":"
915 ^ Int.toString Config.slavePort)
916 in
917 Msg.send (bio, MsgRegenerate);
918 case Msg.recv bio of
919 NONE => print "Slave closed connection unexpectedly\n"
920 | SOME m =>
921 case m of
922 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
923 | MsgError s => print ("Slave " ^ node
924 ^ " returned error: " ^
925 s ^ "\n")
926 | _ => print ("Slave " ^ node
927 ^ " returned unexpected command\n");
928 OpenSSL.close bio
929 end
930 handle OpenSSL.OpenSSL s => print ("OpenSSL error: " ^ s ^ "\n")
931
932 fun doUser user =
933 let
934 val _ = Domain.setUser user
935 val _ = ErrorMsg.reset ()
936
937 val dname = Config.domtoolDir user
938 in
939 if Posix.FileSys.access (dname, []) then
940 let
941 val dir = Posix.FileSys.opendir dname
942
943 fun loop files =
944 case Posix.FileSys.readdir dir of
945 NONE => (Posix.FileSys.closedir dir;
946 files)
947 | SOME fname =>
948 if notTmp fname then
949 loop (OS.Path.joinDirFile {dir = dname,
950 file = fname}
951 :: files)
952 else
953 loop files
954
955 val files = loop []
956 val (_, files) = Order.order (SOME b) files
957 in
958 if !ErrorMsg.anyErrors then
959 (ErrorMsg.reset ();
960 print ("User " ^ user ^ "'s configuration has errors!\n");
961 ok := false)
962 else
963 app checker files
964 end
965 else
966 ()
967 end
968 handle IO.Io {name, function, ...} =>
969 (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");
970 ok := false)
971 | exn as OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
972 ok := false)
973 | ErrorMsg.Error => (ErrorMsg.reset ();
974 print ("User " ^ user ^ " had a compilation error.\n");
975 ok := false)
976 | _ => (print "Unknown exception during regeneration!\n";
977 ok := false)
978 in
979 ifReal (fn () => (app contactNode Config.nodeIps;
980 Env.pre ()));
981 app doUser (Acl.users ());
982 ifReal Env.post;
983 !ok
984 end
985
986 val regenerate = regenerateEither false eval'
987 val regenerateTc = regenerateEither true (ignore o check)
988
989 fun rmuser user =
990 let
991 val doms = Acl.class {user = user, class = "domain"}
992 val doms = List.filter (fn dom =>
993 case Acl.whoHas {class = "domain", value = dom} of
994 [_] => true
995 | _ => false) (StringSet.listItems doms)
996 in
997 Acl.rmuser user;
998 Domain.rmdom doms
999 end
1000
1001 fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
1002
1003 fun answerQuery q =
1004 case q of
1005 QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
1006 | QCron user => if Cron.allowed user then MsgYes else MsgNo
1007 | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
1008 | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
1009 | QSocket user => MsgSocket (SocketPerm.query user)
1010 | QFirewall user => MsgFirewall (Firewall.query user)
1011
1012 fun describeQuery q =
1013 case q of
1014 QApt pkg => "Requested installation status of package " ^ pkg
1015 | QCron user => "Asked about cron permissions for user " ^ user
1016 | QFtp user => "Asked about FTP permissions for user " ^ user
1017 | QTrustedPath user => "Asked about trusted path settings for user " ^ user
1018 | QSocket user => "Asked about socket permissions for user " ^ user
1019 | QFirewall user => "Asked about firewall rules for user " ^ user
1020
1021 fun service () =
1022 let
1023 val () = Acl.read Config.aclFile
1024
1025 val context = context (Config.serverCert,
1026 Config.serverKey,
1027 Config.trustStore)
1028 val _ = Domain.set_context context
1029
1030 val sock = OpenSSL.listen (context, Config.dispatcherPort)
1031
1032 fun loop () =
1033 (case OpenSSL.accept sock of
1034 NONE => ()
1035 | SOME bio =>
1036 let
1037 val user = OpenSSL.peerCN bio
1038 val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
1039 val () = Domain.setUser user
1040
1041 fun doIt f cleanup =
1042 ((case f () of
1043 (msgLocal, SOME msgRemote) =>
1044 (print msgLocal;
1045 print "\n";
1046 Msg.send (bio, MsgError msgRemote))
1047 | (msgLocal, NONE) =>
1048 (print msgLocal;
1049 print "\n";
1050 Msg.send (bio, MsgOk)))
1051 handle e as (OpenSSL.OpenSSL s) =>
1052 (print ("OpenSSL error: " ^ s ^ "\n");
1053 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1054 Msg.send (bio, MsgError ("OpenSSL error: " ^ s))
1055 handle OpenSSL.OpenSSL _ => ())
1056 | OS.SysErr (s, _) =>
1057 (print "System error: ";
1058 print s;
1059 print "\n";
1060 Msg.send (bio, MsgError ("System error: " ^ s))
1061 handle OpenSSL.OpenSSL _ => ())
1062 | Fail s =>
1063 (print "Failure: ";
1064 print s;
1065 print "\n";
1066 Msg.send (bio, MsgError ("Failure: " ^ s))
1067 handle OpenSSL.OpenSSL _ => ())
1068 | ErrorMsg.Error =>
1069 (print "Compilation error\n";
1070 Msg.send (bio, MsgError "Error during configuration evaluation")
1071 handle OpenSSL.OpenSSL _ => ());
1072 (cleanup ();
1073 ignore (OpenSSL.readChar bio);
1074 OpenSSL.close bio)
1075 handle OpenSSL.OpenSSL _ => ();
1076 loop ())
1077
1078 fun doConfig codes =
1079 let
1080 val _ = print "Configuration:\n"
1081 val _ = app (fn s => (print s; print "\n")) codes
1082 val _ = print "\n"
1083
1084 val outname = OS.FileSys.tmpName ()
1085
1086 fun doOne code =
1087 let
1088 val outf = TextIO.openOut outname
1089 in
1090 TextIO.output (outf, code);
1091 TextIO.closeOut outf;
1092 eval' outname
1093 end
1094 in
1095 doIt (fn () => (Env.pre ();
1096 app doOne codes;
1097 Env.post ();
1098 Msg.send (bio, MsgOk);
1099 ("Configuration complete.", NONE)))
1100 (fn () => OS.FileSys.remove outname)
1101 end
1102
1103 fun checkAddr s =
1104 case String.fields (fn ch => ch = #"@") s of
1105 [user'] =>
1106 if user = user' then
1107 SOME (SetSA.User s)
1108 else
1109 NONE
1110 | [user', domain] =>
1111 if Domain.validEmailUser user' andalso Domain.yourDomain domain then
1112 SOME (SetSA.Email s)
1113 else
1114 NONE
1115 | _ => NONE
1116
1117 fun cmdLoop () =
1118 case Msg.recv bio of
1119 NONE => (OpenSSL.close bio
1120 handle OpenSSL.OpenSSL _ => ();
1121 loop ())
1122 | SOME m =>
1123 case m of
1124 MsgConfig code => doConfig [code]
1125 | MsgMultiConfig codes => doConfig codes
1126
1127 | MsgShutdown =>
1128 if Acl.query {user = user, class = "priv", value = "all"}
1129 orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
1130 print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")
1131 else
1132 (print "Unauthorized shutdown command!\n";
1133 OpenSSL.close bio
1134 handle OpenSSL.OpenSSL _ => ();
1135 loop ())
1136
1137 | MsgGrant acl =>
1138 doIt (fn () =>
1139 if Acl.query {user = user, class = "priv", value = "all"} then
1140 (Acl.grant acl;
1141 Acl.write Config.aclFile;
1142 ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
1143 NONE))
1144 else
1145 ("Unauthorized user asked to grant a permission!",
1146 SOME "Not authorized to grant privileges"))
1147 (fn () => ())
1148
1149 | MsgRevoke acl =>
1150 doIt (fn () =>
1151 if Acl.query {user = user, class = "priv", value = "all"} then
1152 (Acl.revoke acl;
1153 Acl.write Config.aclFile;
1154 ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
1155 NONE))
1156 else
1157 ("Unauthorized user asked to revoke a permission!",
1158 SOME "Not authorized to revoke privileges"))
1159 (fn () => ())
1160
1161 | MsgListPerms user =>
1162 doIt (fn () =>
1163 (Msg.send (bio, MsgPerms (Acl.queryAll user));
1164 ("Sent permission list for user " ^ user ^ ".",
1165 NONE)))
1166 (fn () => ())
1167
1168 | MsgWhoHas perm =>
1169 doIt (fn () =>
1170 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
1171 ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
1172 NONE)))
1173 (fn () => ())
1174
1175 | MsgRmdom doms =>
1176 doIt (fn () =>
1177 if Acl.query {user = user, class = "priv", value = "all"}
1178 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
1179 (Domain.rmdom doms;
1180 app (fn dom =>
1181 Acl.revokeFromAll {class = "domain", value = dom}) doms;
1182 Acl.write Config.aclFile;
1183 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
1184 NONE))
1185 else
1186 ("Unauthorized user asked to remove a domain!",
1187 SOME "Not authorized to remove that domain"))
1188 (fn () => ())
1189
1190 | MsgRegenerate =>
1191 doIt (fn () =>
1192 if Acl.query {user = user, class = "priv", value = "regen"}
1193 orelse Acl.query {user = user, class = "priv", value = "all"} then
1194 (if regenerate context then
1195 ("Regenerated all configuration.",
1196 NONE)
1197 else
1198 ("Error regenerating configuration!",
1199 SOME "Error regenerating configuration! Consult /var/log/domtool.log."))
1200 else
1201 ("Unauthorized user asked to regenerate!",
1202 SOME "Not authorized to regenerate"))
1203 (fn () => ())
1204
1205 | MsgRegenerateTc =>
1206 doIt (fn () =>
1207 if Acl.query {user = user, class = "priv", value = "regen"}
1208 orelse Acl.query {user = user, class = "priv", value = "all"} then
1209 (if regenerateTc context then
1210 ("Checked all configuration.",
1211 NONE)
1212 else
1213 ("Found a compilation error!",
1214 SOME "Found a compilation error! Consult /var/log/domtool.log."))
1215 else
1216 ("Unauthorized user asked to regenerate -tc!",
1217 SOME "Not authorized to regenerate -tc"))
1218 (fn () => ())
1219
1220 | MsgRmuser user' =>
1221 doIt (fn () =>
1222 if Acl.query {user = user, class = "priv", value = "all"} then
1223 (rmuser user';
1224 Acl.write Config.aclFile;
1225 ("Removed user " ^ user' ^ ".",
1226 NONE))
1227 else
1228 ("Unauthorized user asked to remove a user!",
1229 SOME "Not authorized to remove users"))
1230 (fn () => ())
1231
1232 | MsgCreateDbUser {dbtype, passwd} =>
1233 doIt (fn () =>
1234 case Dbms.lookup dbtype of
1235 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
1236 SOME ("Unknown database type " ^ dbtype))
1237 | SOME handler =>
1238 case #adduser handler {user = user, passwd = passwd} of
1239 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
1240 NONE)
1241 | SOME msg =>
1242 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
1243 SOME ("Error adding user: " ^ msg)))
1244 (fn () => ())
1245
1246 | MsgDbPasswd {dbtype, passwd} =>
1247 doIt (fn () =>
1248 case Dbms.lookup dbtype of
1249 NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
1250 SOME ("Unknown database type " ^ dbtype))
1251 | SOME handler =>
1252 case #passwd handler {user = user, passwd = passwd} of
1253 NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1254 NONE)
1255 | SOME msg =>
1256 ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1257 SOME ("Error adding user: " ^ msg)))
1258 (fn () => ())
1259
1260 | MsgCreateDb {dbtype, dbname} =>
1261 doIt (fn () =>
1262 if Dbms.validDbname dbname then
1263 case Dbms.lookup dbtype of
1264 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1265 SOME ("Unknown database type " ^ dbtype))
1266 | SOME handler =>
1267 case #createdb handler {user = user, dbname = dbname} of
1268 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1269 NONE)
1270 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1271 SOME ("Error creating database: " ^ msg))
1272 else
1273 ("Invalid database name " ^ user ^ "_" ^ dbname,
1274 SOME ("Invalid database name " ^ dbname)))
1275 (fn () => ())
1276
1277 | MsgDropDb {dbtype, dbname} =>
1278 doIt (fn () =>
1279 if Dbms.validDbname dbname then
1280 case Dbms.lookup dbtype of
1281 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1282 SOME ("Unknown database type " ^ dbtype))
1283 | SOME handler =>
1284 case #dropdb handler {user = user, dbname = dbname} of
1285 NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
1286 NONE)
1287 | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1288 SOME ("Error dropping database: " ^ msg))
1289 else
1290 ("Invalid database name " ^ user ^ "_" ^ dbname,
1291 SOME ("Invalid database name " ^ dbname)))
1292 (fn () => ())
1293
1294 | MsgGrantDb {dbtype, dbname} =>
1295 doIt (fn () =>
1296 if Dbms.validDbname dbname then
1297 case Dbms.lookup dbtype of
1298 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1299 SOME ("Unknown database type " ^ dbtype))
1300 | SOME handler =>
1301 case #grant handler {user = user, dbname = dbname} of
1302 NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
1303 NONE)
1304 | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1305 SOME ("Error granting permissions to database: " ^ msg))
1306 else
1307 ("Invalid database name " ^ user ^ "_" ^ dbname,
1308 SOME ("Invalid database name " ^ dbname)))
1309 (fn () => ())
1310
1311 | MsgListMailboxes domain =>
1312 doIt (fn () =>
1313 if not (Domain.yourDomain domain) then
1314 ("User wasn't authorized to list mailboxes for " ^ domain,
1315 SOME "You're not authorized to configure that domain.")
1316 else
1317 case Vmail.list domain of
1318 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
1319 ("Sent mailbox list for " ^ domain,
1320 NONE))
1321 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
1322 SOME msg))
1323 (fn () => ())
1324
1325 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
1326 doIt (fn () =>
1327 if not (Domain.yourDomain domain) then
1328 ("User wasn't authorized to add a mailbox to " ^ domain,
1329 SOME "You're not authorized to configure that domain.")
1330 else if not (Domain.validEmailUser emailUser) then
1331 ("Invalid e-mail username " ^ emailUser,
1332 SOME "Invalid e-mail username")
1333 else if not (CharVector.all Char.isGraph passwd) then
1334 ("Invalid password",
1335 SOME "Invalid password; may only contain printable, non-space characters")
1336 else if not (Domain.yourPath mailbox) then
1337 ("User wasn't authorized to add a mailbox at " ^ mailbox,
1338 SOME ("You're not authorized to use that mailbox location. ("
1339 ^ mailbox ^ ")"))
1340 else
1341 case Vmail.add {requester = user,
1342 domain = domain, user = emailUser,
1343 passwd = passwd, mailbox = mailbox} of
1344 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
1345 NONE)
1346 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1347 SOME msg))
1348 (fn () => ())
1349
1350 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
1351 doIt (fn () =>
1352 if not (Domain.yourDomain domain) then
1353 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1354 SOME "You're not authorized to configure that domain.")
1355 else if not (Domain.validEmailUser emailUser) then
1356 ("Invalid e-mail username " ^ emailUser,
1357 SOME "Invalid e-mail username")
1358 else if not (CharVector.all Char.isGraph passwd) then
1359 ("Invalid password",
1360 SOME "Invalid password; may only contain printable, non-space characters")
1361 else
1362 case Vmail.passwd {domain = domain, user = emailUser,
1363 passwd = passwd} of
1364 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1365 NONE)
1366 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1367 SOME msg))
1368 (fn () => ())
1369
1370 | MsgRmMailbox {domain, user = emailUser} =>
1371 doIt (fn () =>
1372 if not (Domain.yourDomain domain) then
1373 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1374 SOME "You're not authorized to configure that domain.")
1375 else if not (Domain.validEmailUser emailUser) then
1376 ("Invalid e-mail username " ^ emailUser,
1377 SOME "Invalid e-mail username")
1378 else
1379 case Vmail.rm {domain = domain, user = emailUser} of
1380 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
1381 NONE)
1382 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1383 SOME msg))
1384 (fn () => ())
1385
1386 | MsgSaQuery addr =>
1387 doIt (fn () =>
1388 case checkAddr addr of
1389 NONE => ("User tried to query SA filtering for " ^ addr,
1390 SOME "You aren't allowed to configure SA filtering for that recipient.")
1391 | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
1392 ("Queried SA filtering status for " ^ addr,
1393 NONE)))
1394 (fn () => ())
1395
1396 | MsgSaSet (addr, b) =>
1397 doIt (fn () =>
1398 case checkAddr addr of
1399 NONE => ("User tried to set SA filtering for " ^ addr,
1400 SOME "You aren't allowed to configure SA filtering for that recipient.")
1401 | SOME addr' => (SetSA.set (addr', b);
1402 Msg.send (bio, MsgOk);
1403 ("Set SA filtering status for " ^ addr ^ " to "
1404 ^ (if b then "ON" else "OFF"),
1405 NONE)))
1406 (fn () => ())
1407
1408 | MsgSmtpLogReq domain =>
1409 doIt (fn () =>
1410 if not (Domain.yourDomain domain) then
1411 ("Unauthorized user tried to request SMTP logs for " ^ domain,
1412 SOME "You aren't authorized to configure that domain.")
1413 else
1414 (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1415 domain;
1416 ("Requested SMTP logs for " ^ domain,
1417 NONE)))
1418 (fn () => ())
1419
1420 | MsgQuery q =>
1421 doIt (fn () => (Msg.send (bio, answerQuery q);
1422 (describeQuery q,
1423 NONE)))
1424 (fn () => ())
1425
1426 | MsgMysqlFixperms =>
1427 doIt (fn () => if OS.Process.isSuccess
1428 (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
1429 ("Requested mysql-fixperms",
1430 NONE)
1431 else
1432 ("Requested mysql-fixperms, but execution failed!",
1433 SOME "Script execution failed."))
1434 (fn () => ())
1435
1436 | MsgDescribe dom =>
1437 doIt (fn () => if not (Domain.validDomain dom) then
1438 ("Requested description of invalid domain " ^ dom,
1439 SOME "Invalid domain name")
1440 else if not (Domain.yourDomain dom
1441 orelse Acl.query {user = user, class = "priv", value = "all"}) then
1442 ("Requested description of " ^ dom ^ ", but not allowed access",
1443 SOME "Access denied")
1444 else
1445 (Msg.send (bio, MsgDescription (Domain.describe dom));
1446 ("Sent description of domain " ^ dom,
1447 NONE)))
1448 (fn () => ())
1449
1450 | _ =>
1451 doIt (fn () => ("Unexpected command",
1452 SOME "Unexpected command"))
1453 (fn () => ())
1454 in
1455 cmdLoop ()
1456 end
1457 handle e as (OpenSSL.OpenSSL s) =>
1458 (print ("OpenSSL error: " ^ s ^ "\n");
1459 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1460 OpenSSL.close bio
1461 handle OpenSSL.OpenSSL _ => ();
1462 loop ())
1463 | OS.SysErr (s, _) =>
1464 (print ("System error: " ^ s ^ "\n");
1465 OpenSSL.close bio
1466 handle OpenSSL.OpenSSL _ => ();
1467 loop ())
1468 | IO.Io {name, function, cause} =>
1469 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1470 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1471 OpenSSL.close bio
1472 handle OpenSSL.OpenSSL _ => ();
1473 loop ())
1474 | OS.Path.InvalidArc =>
1475 (print "Invalid arc\n";
1476 OpenSSL.close bio
1477 handle OpenSSL.OpenSSL _ => ();
1478 loop ())
1479 | e =>
1480 (print "Unknown exception in main loop!\n";
1481 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1482 OpenSSL.close bio
1483 handle OpenSSL.OpenSSL _ => ();
1484 loop ()))
1485 handle e as (OpenSSL.OpenSSL s) =>
1486 (print ("OpenSSL error: " ^ s ^ "\n");
1487 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1488 loop ())
1489 | OS.SysErr (s, _) =>
1490 (print ("System error: " ^ s ^ "\n");
1491 loop ())
1492 | IO.Io {name, function, cause} =>
1493 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1494 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1495 loop ())
1496 | e =>
1497 (print "Unknown exception in main loop!\n";
1498 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1499 loop ())
1500 in
1501 print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
1502 print "Listening for connections....\n";
1503 loop ();
1504 OpenSSL.shutdown sock
1505 end
1506
1507 fun slave () =
1508 let
1509 val host = Slave.hostname ()
1510
1511 val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1512 Config.keyDir ^ "/" ^ host ^ "/key.pem",
1513 Config.trustStore)
1514
1515 val sock = OpenSSL.listen (context, Config.slavePort)
1516
1517 val _ = print ("Slave server starting at " ^ now () ^ "\n")
1518
1519 fun loop () =
1520 case OpenSSL.accept sock of
1521 NONE => ()
1522 | SOME bio =>
1523 let
1524 val peer = OpenSSL.peerCN bio
1525 val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
1526 in
1527 if peer = Config.dispatcherName then let
1528 fun loop' files =
1529 case Msg.recv bio of
1530 NONE => print "Dispatcher closed connection unexpectedly\n"
1531 | SOME m =>
1532 case m of
1533 MsgFile file => loop' (file :: files)
1534 | MsgDoFiles => (Slave.handleChanges files;
1535 Msg.send (bio, MsgOk))
1536 | MsgRegenerate => (Domain.resetLocal ();
1537 Msg.send (bio, MsgOk))
1538 | _ => (print "Dispatcher sent unexpected command\n";
1539 Msg.send (bio, MsgError "Unexpected command"))
1540 in
1541 loop' [];
1542 ignore (OpenSSL.readChar bio);
1543 OpenSSL.close bio;
1544 loop ()
1545 end
1546 else if peer = "domtool" then
1547 case Msg.recv bio of
1548 SOME MsgShutdown => (OpenSSL.close bio;
1549 print ("Shutting down at " ^ now () ^ "\n\n"))
1550 | _ => (OpenSSL.close bio;
1551 loop ())
1552 else
1553 case Msg.recv bio of
1554 SOME (MsgQuery q) => (print (describeQuery q ^ "\n");
1555 Msg.send (bio, answerQuery q);
1556 ignore (OpenSSL.readChar bio);
1557 OpenSSL.close bio;
1558 loop ())
1559 | _ => (OpenSSL.close bio;
1560 loop ())
1561 end handle OpenSSL.OpenSSL s =>
1562 (print ("OpenSSL error: "^ s ^ "\n");
1563 OpenSSL.close bio
1564 handle OpenSSL.OpenSSL _ => ();
1565 loop ())
1566 | e as OS.SysErr (s, _) =>
1567 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1568 print ("System error: "^ s ^ "\n");
1569 OpenSSL.close bio
1570 handle OpenSSL.OpenSSL _ => ();
1571 loop ())
1572 in
1573 loop ();
1574 OpenSSL.shutdown sock
1575 end
1576
1577 fun listBasis () =
1578 let
1579 val dir = Posix.FileSys.opendir Config.libRoot
1580
1581 fun loop files =
1582 case Posix.FileSys.readdir dir of
1583 NONE => (Posix.FileSys.closedir dir;
1584 files)
1585 | SOME fname =>
1586 if String.isSuffix ".dtl" fname then
1587 loop (OS.Path.joinDirFile {dir = Config.libRoot,
1588 file = fname}
1589 :: files)
1590 else
1591 loop files
1592 in
1593 loop []
1594 end
1595
1596 fun autodocBasis outdir =
1597 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1598
1599 end