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