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