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