57833480f56822daeaef3ffc17c7380721966f50
[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 (_, context) = requestContext (fn () => ())
539 val bio = OpenSSL.connect true (context,
540 Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
541 in
542 Msg.send (bio, MsgCreateDbUser dbtype);
543 case Msg.recv bio of
544 NONE => print "Server closed connection unexpectedly.\n"
545 | SOME m =>
546 case m of
547 MsgOk => print "Your user has been created.\n"
548 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
549 | _ => print "Unexpected server reply.\n";
550 OpenSSL.close bio
551 end
552
553 fun requestDbPasswd rc =
554 let
555 val (_, context) = requestContext (fn () => ())
556 val bio = OpenSSL.connect true (context,
557 Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
558 in
559 Msg.send (bio, MsgDbPasswd rc);
560 case Msg.recv bio of
561 NONE => print "Server closed connection unexpectedly.\n"
562 | SOME m =>
563 case m of
564 MsgOk => print "Your password has been changed.\n"
565 | MsgError s => print ("Password set failed: " ^ s ^ "\n")
566 | _ => print "Unexpected server reply.\n";
567 OpenSSL.close bio
568 end
569
570 fun requestDbTable p =
571 let
572 val (user, context) = requestContext (fn () => ())
573 val bio = OpenSSL.connect true (context,
574 Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
575 in
576 Msg.send (bio, MsgCreateDb p);
577 case Msg.recv bio of
578 NONE => print "Server closed connection unexpectedly.\n"
579 | SOME m =>
580 case m of
581 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
582 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
583 | _ => print "Unexpected server reply.\n";
584 OpenSSL.close bio
585 end
586
587 fun requestDbDrop p =
588 let
589 val (user, context) = requestContext (fn () => ())
590 val bio = OpenSSL.connect true (context,
591 Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
592 in
593 Msg.send (bio, MsgDropDb p);
594 case Msg.recv bio of
595 NONE => print "Server closed connection unexpectedly.\n"
596 | SOME m =>
597 case m of
598 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been dropped.\n")
599 | MsgError s => print ("Drop failed: " ^ s ^ "\n")
600 | _ => print "Unexpected server reply.\n";
601 OpenSSL.close bio
602 end
603
604 fun requestDbGrant p =
605 let
606 val (user, context) = requestContext (fn () => ())
607 val bio = OpenSSL.connect true (context,
608 Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
609 in
610 Msg.send (bio, MsgGrantDb p);
611 case Msg.recv bio of
612 NONE => print "Server closed connection unexpectedly.\n"
613 | SOME m =>
614 case m of
615 MsgOk => print ("You've been granted all allowed privileges to database " ^ user ^ "_" ^ #dbname p ^ ".\n")
616 | MsgError s => print ("Grant failed: " ^ s ^ "\n")
617 | _ => print "Unexpected server reply.\n";
618 OpenSSL.close bio
619 end
620
621 fun requestListMailboxes domain =
622 let
623 val (_, bio) = requestBio (fn () => ())
624 in
625 Msg.send (bio, MsgListMailboxes domain);
626 (case Msg.recv bio of
627 NONE => Vmail.Error "Server closed connection unexpectedly."
628 | SOME m =>
629 case m of
630 MsgMailboxes users => (Msg.send (bio, MsgOk);
631 Vmail.Listing users)
632 | MsgError s => Vmail.Error ("Listing failed: " ^ s)
633 | _ => Vmail.Error "Unexpected server reply.")
634 before OpenSSL.close bio
635 end
636
637 fun requestNewMailbox p =
638 let
639 val (_, bio) = requestBio (fn () => ())
640 in
641 Msg.send (bio, MsgNewMailbox p);
642 case Msg.recv bio of
643 NONE => print "Server closed connection unexpectedly.\n"
644 | SOME m =>
645 case m of
646 MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")
647 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
648 | _ => print "Unexpected server reply.\n";
649 OpenSSL.close bio
650 end
651
652 fun requestPasswdMailbox p =
653 let
654 val (_, bio) = requestBio (fn () => ())
655 in
656 Msg.send (bio, MsgPasswdMailbox p);
657 case Msg.recv bio of
658 NONE => print "Server closed connection unexpectedly.\n"
659 | SOME m =>
660 case m of
661 MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
662 | MsgError s => print ("Set failed: " ^ s ^ "\n")
663 | _ => print "Unexpected server reply.\n";
664 OpenSSL.close bio
665 end
666
667 fun requestRmMailbox p =
668 let
669 val (_, bio) = requestBio (fn () => ())
670 in
671 Msg.send (bio, MsgRmMailbox p);
672 case Msg.recv bio of
673 NONE => print "Server closed connection unexpectedly.\n"
674 | SOME m =>
675 case m of
676 MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")
677 | MsgError s => print ("Remove failed: " ^ s ^ "\n")
678 | _ => print "Unexpected server reply.\n";
679 OpenSSL.close bio
680 end
681
682 fun requestSaQuery addr =
683 let
684 val (_, bio) = requestBio (fn () => ())
685 in
686 Msg.send (bio, MsgSaQuery addr);
687 (case Msg.recv bio of
688 NONE => print "Server closed connection unexpectedly.\n"
689 | SOME m =>
690 case m of
691 MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is "
692 ^ (if b then "ON" else "OFF") ^ ".\n");
693 Msg.send (bio, MsgOk))
694 | MsgError s => print ("Query failed: " ^ s ^ "\n")
695 | _ => print "Unexpected server reply.\n")
696 before OpenSSL.close bio
697 end
698
699 fun requestSaSet p =
700 let
701 val (_, bio) = requestBio (fn () => ())
702 in
703 Msg.send (bio, MsgSaSet p);
704 case Msg.recv bio of
705 NONE => print "Server closed connection unexpectedly.\n"
706 | SOME m =>
707 case m of
708 MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now "
709 ^ (if #2 p then "ON" else "OFF") ^ ".\n")
710 | MsgError s => print ("Set failed: " ^ s ^ "\n")
711 | _ => print "Unexpected server reply.\n";
712 OpenSSL.close bio
713 end
714
715 fun requestSmtpLog domain =
716 let
717 val (_, bio) = requestBio (fn () => ())
718
719 val _ = Msg.send (bio, MsgSmtpLogReq domain)
720
721 fun loop () =
722 case Msg.recv bio of
723 NONE => print "Server closed connection unexpectedly.\n"
724 | SOME m =>
725 case m of
726 MsgOk => ()
727 | MsgSmtpLogRes line => (print line;
728 loop ())
729 | MsgError s => print ("Log search failed: " ^ s ^ "\n")
730 | _ => print "Unexpected server reply.\n"
731 in
732 loop ();
733 OpenSSL.close bio
734 end
735
736 fun requestMysqlFixperms () =
737 let
738 val (_, context) = requestContext (fn () => ())
739 val bio = OpenSSL.connect true (context,
740 Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
741 in
742 Msg.send (bio, MsgMysqlFixperms);
743 case Msg.recv bio of
744 NONE => print "Server closed connection unexpectedly.\n"
745 | SOME m =>
746 case m of
747 MsgOk => print "Permissions granted.\n"
748 | MsgError s => print ("Failed: " ^ s ^ "\n")
749 | _ => print "Unexpected server reply.\n";
750 OpenSSL.close bio
751 end
752
753 fun requestApt {node, pkg} =
754 let
755 val (user, context) = requestContext (fn () => ())
756 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
757 dispatcher
758 else
759 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
760
761 val _ = Msg.send (bio, MsgQuery (QApt pkg))
762
763 fun loop () =
764 case Msg.recv bio of
765 NONE => (print "Server closed connection unexpectedly.\n";
766 OS.Process.failure)
767 | SOME m =>
768 case m of
769 MsgYes => (print "Package is installed.\n";
770 OS.Process.success)
771 | MsgNo => (print "Package is not installed.\n";
772 OS.Process.failure)
773 | MsgError s => (print ("APT query failed: " ^ s ^ "\n");
774 OS.Process.failure)
775 | _ => (print "Unexpected server reply.\n";
776 OS.Process.failure)
777 in
778 loop ()
779 before OpenSSL.close bio
780 end
781
782 fun requestAptExists {node, pkg} =
783 let
784 val (user, context) = requestContext (fn () => ())
785 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
786 dispatcher
787 else
788 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
789
790 val _ = Msg.send (bio, MsgQuery (QAptExists pkg))
791
792 fun loop () =
793 case Msg.recv bio of
794 NONE => (print "Server closed connection unexpectedly.\n";
795 OS.Process.failure)
796 | SOME m =>
797 case m of
798 MsgAptQuery {section,description} => (print "Package exists.\n";
799 print ("Section: " ^ section ^ "\n");
800 print ("Description: " ^ description ^ "\n");
801 OS.Process.success)
802 | MsgNo => (print "Package does not exist.\n";
803 OS.Process.failure
804 (* It might be the Wrong Thing (tm) to use MsgNo like this *))
805 | MsgError s => (print ("APT existence query failed: " ^ s ^ "\n");
806 OS.Process.failure)
807 | _ => (print "Unexpected server reply.\n";
808 OS.Process.failure)
809 in
810 loop ()
811 before OpenSSL.close bio
812 end
813
814 fun requestCron {node, uname} =
815 let
816 val (user, context) = requestContext (fn () => ())
817 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
818 dispatcher
819 else
820 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
821
822 val _ = Msg.send (bio, MsgQuery (QCron uname))
823
824 fun loop () =
825 case Msg.recv bio of
826 NONE => (print "Server closed connection unexpectedly.\n";
827 OS.Process.failure)
828 | SOME m =>
829 case m of
830 MsgYes => (print "User has cron permissions.\n";
831 OS.Process.success)
832 | MsgNo => (print "User does not have cron permissions.\n";
833 OS.Process.failure)
834 | MsgError s => (print ("Cron query failed: " ^ s ^ "\n");
835 OS.Process.failure)
836 | _ => (print "Unexpected server reply.\n";
837 OS.Process.failure)
838 in
839 loop ()
840 before OpenSSL.close bio
841 end
842
843 fun requestFtp {node, uname} =
844 let
845 val (user, context) = requestContext (fn () => ())
846 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
847 dispatcher
848 else
849 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
850
851 val _ = Msg.send (bio, MsgQuery (QFtp uname))
852
853 fun loop () =
854 case Msg.recv bio of
855 NONE => (print "Server closed connection unexpectedly.\n";
856 OS.Process.failure)
857 | SOME m =>
858 case m of
859 MsgYes => (print "User has FTP permissions.\n";
860 OS.Process.success)
861 | MsgNo => (print "User does not have FTP permissions.\n";
862 OS.Process.failure)
863 | MsgError s => (print ("FTP query failed: " ^ s ^ "\n");
864 OS.Process.failure)
865 | _ => (print "Unexpected server reply.\n";
866 OS.Process.failure)
867 in
868 loop ()
869 before OpenSSL.close bio
870 end
871
872 fun requestTrustedPath {node, uname} =
873 let
874 val (user, context) = requestContext (fn () => ())
875 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
876 dispatcher
877 else
878 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
879
880 val _ = Msg.send (bio, MsgQuery (QTrustedPath uname))
881
882 fun loop () =
883 case Msg.recv bio of
884 NONE => (print "Server closed connection unexpectedly.\n";
885 OS.Process.failure)
886 | SOME m =>
887 case m of
888 MsgYes => (print "User has trusted path restriction.\n";
889 OS.Process.success)
890 | MsgNo => (print "User does not have trusted path restriction.\n";
891 OS.Process.failure)
892 | MsgError s => (print ("Trusted path query failed: " ^ s ^ "\n");
893 OS.Process.failure)
894 | _ => (print "Unexpected server reply.\n";
895 OS.Process.failure)
896 in
897 loop ()
898 before OpenSSL.close bio
899 end
900
901 fun requestSocketPerm {node, uname} =
902 let
903 val (user, context) = requestContext (fn () => ())
904 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
905 dispatcher
906 else
907 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
908
909 val _ = Msg.send (bio, MsgQuery (QSocket uname))
910
911 fun loop () =
912 case Msg.recv bio of
913 NONE => (print "Server closed connection unexpectedly.\n";
914 OS.Process.failure)
915 | SOME m =>
916 case m of
917 MsgSocket p => (case p of
918 Any => print "Any\n"
919 | Client => print "Client\n"
920 | Server => print "Server\n"
921 | Nada => print "Nada\n";
922 OS.Process.success)
923 | MsgError s => (print ("Socket permission query failed: " ^ s ^ "\n");
924 OS.Process.failure)
925 | _ => (print "Unexpected server reply.\n";
926 OS.Process.failure)
927 in
928 loop ()
929 before OpenSSL.close bio
930 end
931
932 fun requestFirewall {node, uname} =
933 let
934 val (user, context) = requestContext (fn () => ())
935 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
936 dispatcher
937 else
938 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
939
940 val _ = Msg.send (bio, MsgQuery (QFirewall {node = node, user = uname}))
941
942 fun loop () =
943 case Msg.recv bio of
944 NONE => (print "Server closed connection unexpectedly.\n";
945 OS.Process.failure)
946 | SOME m =>
947 case m of
948 MsgFirewall ls => (app (fn s => (print s; print "\n")) ls;
949 OS.Process.success)
950 | MsgError s => (print ("Firewall query failed: " ^ s ^ "\n");
951 OS.Process.failure)
952 | _ => (print "Unexpected server reply.\n";
953 OS.Process.failure)
954 in
955 loop ()
956 before OpenSSL.close bio
957 end
958
959 fun requestDescribe dom =
960 let
961 val (_, bio) = requestBio (fn () => ())
962 in
963 Msg.send (bio, MsgDescribe dom);
964 case Msg.recv bio of
965 NONE => print "Server closed connection unexpectedly.\n"
966 | SOME m =>
967 case m of
968 MsgDescription s => print s
969 | MsgError s => print ("Description failed: " ^ s ^ "\n")
970 | _ => print "Unexpected server reply.\n";
971 OpenSSL.close bio
972 end
973
974 fun requestReUsers () =
975 let
976 val (_, bio) = requestBio (fn () => ())
977 in
978 Msg.send (bio, MsgReUsers);
979 case Msg.recv bio of
980 NONE => print "Server closed connection unexpectedly.\n"
981 | SOME m =>
982 case m of
983 MsgOk => print "Callbacks run.\n"
984 | MsgError s => print ("Failed: " ^ s ^ "\n")
985 | _ => print "Unexpected server reply.\n";
986 OpenSSL.close bio
987 end
988
989 fun requestFirewallRegen node =
990 let
991 val (user, context) = requestContext (fn () => ())
992 val bio = OpenSSL.connect true (context, Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
993 (* Only supporting on slave nodes *)
994
995 val _ = Msg.send (bio, MsgFirewallRegen)
996
997 fun handleResult () =
998 case Msg.recv bio of
999 NONE => (print "Server closed connection unexpectedly.\n";
1000 OS.Process.failure)
1001 | SOME m =>
1002 case m of
1003 MsgOk => (print "Firewall regenerated.\n";
1004 OS.Process.success)
1005 | MsgError s => (print ("Firewall regeneration failed: " ^ s ^ "\n");
1006 OS.Process.failure)
1007 | _ => (print "Unexpected server reply.\n";
1008 OS.Process.failure)
1009 in
1010 handleResult()
1011 before OpenSSL.close bio
1012 end
1013
1014 structure SS = StringSet
1015
1016 fun domainList dname =
1017 let
1018 val dir = Posix.FileSys.opendir dname
1019
1020 fun visitNode dset =
1021 case Posix.FileSys.readdir dir of
1022 NONE => dset
1023 | SOME node =>
1024 let
1025 val path = OS.Path.joinDirFile {dir = dname,
1026 file = node}
1027
1028 fun visitDomains (path, bfor, dset) =
1029 let
1030 val dir = Posix.FileSys.opendir path
1031
1032 fun loop dset =
1033 case Posix.FileSys.readdir dir of
1034 NONE => dset
1035 | SOME dname =>
1036 let
1037 val path = OS.Path.joinDirFile {dir = path,
1038 file = dname}
1039 in
1040 if Posix.FileSys.ST.isDir (Posix.FileSys.stat path) then
1041 let
1042 val bfor = dname :: bfor
1043 in
1044 loop (visitDomains (path, bfor,
1045 SS.add (dset,
1046 String.concatWith "." bfor)))
1047 end
1048 else
1049 loop dset
1050 end
1051 in
1052 loop dset
1053 before Posix.FileSys.closedir dir
1054 end
1055 in
1056 visitNode (visitDomains (path, [], dset))
1057 end
1058 in
1059 visitNode SS.empty
1060 before Posix.FileSys.closedir dir
1061 end
1062
1063 fun regenerateEither tc checker context =
1064 let
1065 val () = print "Starting regeneration....\n"
1066
1067 val domainsBefore =
1068 if tc then
1069 SS.empty
1070 else
1071 domainList Config.resultRoot
1072
1073 fun ifReal f =
1074 if tc then
1075 ()
1076 else
1077 f ()
1078
1079 val _ = ErrorMsg.reset ()
1080
1081 val b = basis ()
1082 val () = Tycheck.disallowExterns ()
1083
1084 val () = ifReal (fn () =>
1085 (ignore (OS.Process.system ("rm -rf " ^ Config.oldResultRoot ^ "/*"));
1086 ignore (OS.Process.system ("cp -r " ^ Config.resultRoot
1087 ^ "/* " ^ Config.oldResultRoot ^ "/"));
1088 Domain.resetGlobal ()))
1089
1090 val ok = ref true
1091
1092 fun contactNode (node, ip) =
1093 if node = Config.defaultNode then
1094 Domain.resetLocal ()
1095 else let
1096 val bio = OpenSSL.connect true (context,
1097 ip
1098 ^ ":"
1099 ^ Int.toString Config.slavePort)
1100 in
1101 Msg.send (bio, MsgRegenerate);
1102 case Msg.recv bio of
1103 NONE => print "Slave closed connection unexpectedly\n"
1104 | SOME m =>
1105 case m of
1106 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
1107 | MsgError s => print ("Slave " ^ node
1108 ^ " returned error: " ^
1109 s ^ "\n")
1110 | _ => print ("Slave " ^ node
1111 ^ " returned unexpected command\n");
1112 OpenSSL.close bio
1113 end
1114 handle OpenSSL.OpenSSL s => print ("OpenSSL error: " ^ s ^ "\n")
1115
1116 fun doUser user =
1117 let
1118 val _ = Domain.setUser user
1119 val _ = ErrorMsg.reset ()
1120
1121 val dname = Config.domtoolDir user
1122 in
1123 if Posix.FileSys.access (dname, []) then
1124 let
1125 val dir = Posix.FileSys.opendir dname
1126
1127 fun loop files =
1128 case Posix.FileSys.readdir dir of
1129 NONE => (Posix.FileSys.closedir dir;
1130 files)
1131 | SOME fname =>
1132 if notTmp fname then
1133 loop (OS.Path.joinDirFile {dir = dname,
1134 file = fname}
1135 :: files)
1136 else
1137 loop files
1138
1139 val files = loop []
1140 val (_, files) = Order.order (SOME b) files
1141
1142 fun checker' (file, (G, evs)) =
1143 checker G evs file
1144 in
1145 if !ErrorMsg.anyErrors then
1146 (ErrorMsg.reset ();
1147 print ("User " ^ user ^ "'s configuration has errors!\n");
1148 ok := false)
1149 else
1150 ();
1151 ignore (foldl checker' (basis (), Defaults.eInit ()) files)
1152 end
1153 else if String.isSuffix "_admin" user then
1154 ()
1155 else
1156 (print ("Couldn't access " ^ user ^ "'s ~/.domtool directory.\n");
1157 ok := false)
1158 end
1159 handle IO.Io {name, function, ...} =>
1160 (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");
1161 ok := false)
1162 | exn as OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
1163 ok := false)
1164 | ErrorMsg.Error => (ErrorMsg.reset ();
1165 print ("User " ^ user ^ " had a compilation error.\n");
1166 ok := false)
1167 | _ => (print "Unknown exception during regeneration!\n";
1168 ok := false)
1169 in
1170 ifReal (fn () => (app contactNode Config.nodeIps;
1171 Env.pre ()));
1172 app doUser (Acl.users ());
1173 ifReal (fn () =>
1174 let
1175 val domainsAfter = domainList Config.resultRoot
1176 val domainsGone = SS.difference (domainsBefore, domainsAfter)
1177 in
1178 if SS.isEmpty domainsGone then
1179 ()
1180 else
1181 (print "Domains to kill:";
1182 SS.app (fn s => (print " "; print s)) domainsGone;
1183 print "\n";
1184
1185 Domain.rmdom' Config.oldResultRoot (SS.listItems domainsGone));
1186
1187 Env.post ()
1188 end);
1189 !ok
1190 end
1191
1192 val regenerate = regenerateEither false eval
1193 val regenerateTc = regenerateEither true
1194 (fn G => fn evs => fn file =>
1195 (#1 (check G file), evs))
1196
1197 fun usersChanged () =
1198 (Domain.onUsersChange ();
1199 ignore (OS.Process.system Config.publish_reusers))
1200
1201 fun rmuser user =
1202 let
1203 val doms = Acl.class {user = user, class = "domain"}
1204 val doms = List.filter (fn dom =>
1205 case Acl.whoHas {class = "domain", value = dom} of
1206 [_] => true
1207 | _ => false) (StringSet.listItems doms)
1208 in
1209 Acl.rmuser user;
1210 Domain.rmdom doms;
1211 usersChanged ()
1212 end
1213
1214 fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
1215
1216 fun answerQuery q =
1217 case q of
1218 QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
1219 | QAptExists pkg => (case Apt.info pkg of
1220 SOME {section, description} => MsgAptQuery {section = section, description = description}
1221 | NONE => MsgNo)
1222 | QCron user => if Cron.allowed user then MsgYes else MsgNo
1223 | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
1224 | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
1225 | QSocket user => MsgSocket (SocketPerm.query user)
1226 | QFirewall {node, user} => MsgFirewall (Firewall.query (node, user))
1227
1228 fun describeQuery q =
1229 case q of
1230 QApt pkg => "Requested installation status of package " ^ pkg
1231 | QAptExists pkg => "Requested if package " ^ pkg ^ " exists"
1232 | QCron user => "Asked about cron permissions for user " ^ user
1233 | QFtp user => "Asked about FTP permissions for user " ^ user
1234 | QTrustedPath user => "Asked about trusted path settings for user " ^ user
1235 | QSocket user => "Asked about socket permissions for user " ^ user
1236 | QFirewall {node, user} => "Asked about firewall rules on " ^ node ^ " for user " ^ user
1237
1238 fun doIt' loop bio f cleanup =
1239 ((case f () of
1240 (msgLocal, SOME msgRemote) =>
1241 (print msgLocal;
1242 print "\n";
1243 Msg.send (bio, MsgError msgRemote))
1244 | (msgLocal, NONE) =>
1245 (print msgLocal;
1246 print "\n";
1247 Msg.send (bio, MsgOk)))
1248 handle e as (OpenSSL.OpenSSL s) =>
1249 (print ("OpenSSL error: " ^ s ^ "\n");
1250 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1251 Msg.send (bio, MsgError ("OpenSSL error: " ^ s))
1252 handle OpenSSL.OpenSSL _ => ())
1253 | OS.SysErr (s, _) =>
1254 (print "System error: ";
1255 print s;
1256 print "\n";
1257 Msg.send (bio, MsgError ("System error: " ^ s))
1258 handle OpenSSL.OpenSSL _ => ())
1259 | Fail s =>
1260 (print "Failure: ";
1261 print s;
1262 print "\n";
1263 Msg.send (bio, MsgError ("Failure: " ^ s))
1264 handle OpenSSL.OpenSSL _ => ())
1265 | ErrorMsg.Error =>
1266 (print "Compilation error\n";
1267 Msg.send (bio, MsgError "Error during configuration evaluation")
1268 handle OpenSSL.OpenSSL _ => ());
1269 (cleanup ();
1270 ignore (OpenSSL.readChar bio);
1271 OpenSSL.close bio)
1272 handle OpenSSL.OpenSSL _ => ();
1273 loop ())
1274
1275 fun service () =
1276 let
1277 val host = Slave.hostname ()
1278
1279 val () = Acl.read Config.aclFile
1280
1281 val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1282 Config.keyDir ^ "/" ^ host ^ "/key.pem",
1283 Config.trustStore)
1284 val _ = Domain.set_context context
1285
1286 val sock = OpenSSL.listen (context, Config.dispatcherPort)
1287
1288 fun loop () =
1289 (case OpenSSL.accept sock of
1290 NONE => ()
1291 | SOME bio =>
1292 let
1293 val user = OpenSSL.peerCN bio
1294 val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
1295 val () = Domain.setUser user
1296 val doIt = doIt' loop bio
1297
1298 fun doConfig codes =
1299 let
1300 val _ = print "Configuration:\n"
1301 val _ = app (fn s => (print s; print "\n")) codes
1302 val _ = print "\n"
1303
1304 val outname = OS.FileSys.tmpName ()
1305
1306 fun doOne (code, (G, evs)) =
1307 let
1308 val outf = TextIO.openOut outname
1309 in
1310 TextIO.output (outf, code);
1311 TextIO.closeOut outf;
1312 eval G evs outname
1313 end
1314 in
1315 doIt (fn () => (Env.pre ();
1316 ignore (foldl doOne (basis (), Defaults.eInit ()) codes);
1317 Env.post ();
1318 Msg.send (bio, MsgOk);
1319 ("Configuration complete.", NONE)))
1320 (fn () => OS.FileSys.remove outname)
1321 end
1322
1323 fun checkAddr s =
1324 case String.fields (fn ch => ch = #"@") s of
1325 [user'] =>
1326 if user = user' then
1327 SOME (SetSA.User s)
1328 else
1329 NONE
1330 | [user', domain] =>
1331 if Domain.validEmailUser user' andalso Domain.yourDomain domain then
1332 SOME (SetSA.Email s)
1333 else
1334 NONE
1335 | _ => NONE
1336
1337 fun cmdLoop () =
1338 case Msg.recv bio of
1339 NONE => (OpenSSL.close bio
1340 handle OpenSSL.OpenSSL _ => ();
1341 loop ())
1342 | SOME m =>
1343 case m of
1344 MsgConfig code => doConfig [code]
1345 | MsgMultiConfig codes => doConfig codes
1346
1347 | MsgShutdown =>
1348 if Acl.query {user = user, class = "priv", value = "all"}
1349 orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
1350 print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")
1351 else
1352 (print "Unauthorized shutdown command!\n";
1353 OpenSSL.close bio
1354 handle OpenSSL.OpenSSL _ => ();
1355 loop ())
1356
1357 | MsgGrant acl =>
1358 doIt (fn () =>
1359 if Acl.query {user = user, class = "priv", value = "all"} then
1360 (Acl.grant acl;
1361 Acl.write Config.aclFile;
1362 if #class acl = "user" then
1363 usersChanged ()
1364 else
1365 ();
1366 ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
1367 NONE))
1368 else
1369 ("Unauthorized user asked to grant a permission!",
1370 SOME "Not authorized to grant privileges"))
1371 (fn () => ())
1372
1373 | MsgRevoke acl =>
1374 doIt (fn () =>
1375 if Acl.query {user = user, class = "priv", value = "all"} then
1376 (Acl.revoke acl;
1377 Acl.write Config.aclFile;
1378 ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
1379 NONE))
1380 else
1381 ("Unauthorized user asked to revoke a permission!",
1382 SOME "Not authorized to revoke privileges"))
1383 (fn () => ())
1384
1385 | MsgListPerms user =>
1386 doIt (fn () =>
1387 (Msg.send (bio, MsgPerms (Acl.queryAll user));
1388 ("Sent permission list for user " ^ user ^ ".",
1389 NONE)))
1390 (fn () => ())
1391
1392 | MsgWhoHas perm =>
1393 doIt (fn () =>
1394 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
1395 ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
1396 NONE)))
1397 (fn () => ())
1398
1399 | MsgRmdom doms =>
1400 doIt (fn () =>
1401 if Acl.query {user = user, class = "priv", value = "all"}
1402 orelse List.all (fn dom => Domain.validDomain dom
1403 andalso Acl.queryDomain {user = user, domain = dom}) doms then
1404 (Domain.rmdom doms;
1405 (*app (fn dom =>
1406 Acl.revokeFromAll {class = "domain", value = dom}) doms;
1407 Acl.write Config.aclFile;*)
1408 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
1409 NONE))
1410 else
1411 ("Unauthorized user asked to remove a domain!",
1412 SOME "Not authorized to remove that domain"))
1413 (fn () => ())
1414
1415 | MsgRegenerate =>
1416 doIt (fn () =>
1417 if Acl.query {user = user, class = "priv", value = "regen"}
1418 orelse Acl.query {user = user, class = "priv", value = "all"} then
1419 (if regenerate context then
1420 ("Regenerated all configuration.",
1421 NONE)
1422 else
1423 ("Error regenerating configuration!",
1424 SOME "Error regenerating configuration! Consult /var/log/domtool.log."))
1425 else
1426 ("Unauthorized user asked to regenerate!",
1427 SOME "Not authorized to regenerate"))
1428 (fn () => ())
1429
1430 | MsgRegenerateTc =>
1431 doIt (fn () =>
1432 if Acl.query {user = user, class = "priv", value = "regen"}
1433 orelse Acl.query {user = user, class = "priv", value = "all"} then
1434 (if regenerateTc context then
1435 ("Checked all configuration.",
1436 NONE)
1437 else
1438 ("Found a compilation error!",
1439 SOME "Found a compilation error! Consult /var/log/domtool.log."))
1440 else
1441 ("Unauthorized user asked to regenerate -tc!",
1442 SOME "Not authorized to regenerate -tc"))
1443 (fn () => ())
1444
1445 | MsgRmuser user' =>
1446 doIt (fn () =>
1447 if Acl.query {user = user, class = "priv", value = "all"} then
1448 (rmuser user';
1449 Acl.write Config.aclFile;
1450 ("Removed user " ^ user' ^ ".",
1451 NONE))
1452 else
1453 ("Unauthorized user asked to remove a user!",
1454 SOME "Not authorized to remove users"))
1455 (fn () => ())
1456
1457 | MsgListMailboxes domain =>
1458 doIt (fn () =>
1459 if not (Domain.yourDomain domain) then
1460 ("User wasn't authorized to list mailboxes for " ^ domain,
1461 SOME "You're not authorized to configure that domain.")
1462 else
1463 case Vmail.list domain of
1464 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
1465 ("Sent mailbox list for " ^ domain,
1466 NONE))
1467 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
1468 SOME msg))
1469 (fn () => ())
1470
1471 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
1472 doIt (fn () =>
1473 if not (Domain.yourDomain domain) then
1474 ("User wasn't authorized to add a mailbox to " ^ domain,
1475 SOME "You're not authorized to configure that domain.")
1476 else if not (Domain.validEmailUser emailUser) then
1477 ("Invalid e-mail username " ^ emailUser,
1478 SOME "Invalid e-mail username")
1479 else if not (CharVector.all Char.isGraph passwd) then
1480 ("Invalid password",
1481 SOME "Invalid password; may only contain printable, non-space characters")
1482 else if not (Domain.yourPath mailbox) then
1483 ("User wasn't authorized to add a mailbox at " ^ mailbox,
1484 SOME ("You're not authorized to use that mailbox location. ("
1485 ^ mailbox ^ ")"))
1486 else
1487 case Vmail.add {requester = user,
1488 domain = domain, user = emailUser,
1489 passwd = passwd, mailbox = mailbox} of
1490 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
1491 NONE)
1492 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1493 SOME msg))
1494 (fn () => ())
1495
1496 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
1497 doIt (fn () =>
1498 if not (Domain.yourDomain domain) then
1499 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1500 SOME "You're not authorized to configure that domain.")
1501 else if not (Domain.validEmailUser emailUser) then
1502 ("Invalid e-mail username " ^ emailUser,
1503 SOME "Invalid e-mail username")
1504 else if not (CharVector.all Char.isGraph passwd) then
1505 ("Invalid password",
1506 SOME "Invalid password; may only contain printable, non-space characters")
1507 else
1508 case Vmail.passwd {domain = domain, user = emailUser,
1509 passwd = passwd} of
1510 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1511 NONE)
1512 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1513 SOME msg))
1514 (fn () => ())
1515
1516 | MsgRmMailbox {domain, user = emailUser} =>
1517 doIt (fn () =>
1518 if not (Domain.yourDomain domain) then
1519 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1520 SOME "You're not authorized to configure that domain.")
1521 else if not (Domain.validEmailUser emailUser) then
1522 ("Invalid e-mail username " ^ emailUser,
1523 SOME "Invalid e-mail username")
1524 else
1525 case Vmail.rm {domain = domain, user = emailUser} of
1526 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
1527 NONE)
1528 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1529 SOME msg))
1530 (fn () => ())
1531
1532 | MsgSaQuery addr =>
1533 doIt (fn () =>
1534 case checkAddr addr of
1535 NONE => ("User tried to query SA filtering for " ^ addr,
1536 SOME "You aren't allowed to configure SA filtering for that recipient.")
1537 | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
1538 ("Queried SA filtering status for " ^ addr,
1539 NONE)))
1540 (fn () => ())
1541
1542 | MsgSaSet (addr, b) =>
1543 doIt (fn () =>
1544 case checkAddr addr of
1545 NONE => ("User tried to set SA filtering for " ^ addr,
1546 SOME "You aren't allowed to configure SA filtering for that recipient.")
1547 | SOME addr' => (SetSA.set (addr', b);
1548 Msg.send (bio, MsgOk);
1549 ("Set SA filtering status for " ^ addr ^ " to "
1550 ^ (if b then "ON" else "OFF"),
1551 NONE)))
1552 (fn () => ())
1553
1554 | MsgSmtpLogReq domain =>
1555 doIt (fn () =>
1556 if not (Domain.yourDomain domain) then
1557 ("Unauthorized user tried to request SMTP logs for " ^ domain,
1558 SOME "You aren't authorized to configure that domain.")
1559 else
1560 (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1561 domain;
1562 ("Requested SMTP logs for " ^ domain,
1563 NONE)))
1564 (fn () => ())
1565
1566 | MsgQuery q =>
1567 doIt (fn () => (Msg.send (bio, answerQuery q);
1568 (describeQuery q,
1569 NONE)))
1570 (fn () => ())
1571 | MsgDescribe dom =>
1572 doIt (fn () => if not (Domain.validDomain dom) then
1573 ("Requested description of invalid domain " ^ dom,
1574 SOME "Invalid domain name")
1575 else if not (Domain.yourDomain dom
1576 orelse Acl.query {user = user, class = "priv", value = "all"}) then
1577 ("Requested description of " ^ dom ^ ", but not allowed access",
1578 SOME "Access denied")
1579 else
1580 (Msg.send (bio, MsgDescription (Domain.describe dom));
1581 ("Sent description of domain " ^ dom,
1582 NONE)))
1583 (fn () => ())
1584
1585 | MsgReUsers =>
1586 doIt (fn () => if Acl.query {user = user, class = "priv", value = "regen"}
1587 orelse Acl.query {user = user, class = "priv", value = "all"} then
1588 (usersChanged ();
1589 ("Users change callbacks run", NONE))
1590 else
1591 ("Unauthorized user asked to reusers!",
1592 SOME "You aren't authorized to regenerate files."))
1593 (fn () => ())
1594
1595 | _ =>
1596 doIt (fn () => ("Unexpected command",
1597 SOME "Unexpected command"))
1598 (fn () => ())
1599 in
1600 cmdLoop ()
1601 end
1602 handle e as (OpenSSL.OpenSSL s) =>
1603 (print ("OpenSSL error: " ^ s ^ "\n");
1604 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1605 OpenSSL.close bio
1606 handle OpenSSL.OpenSSL _ => ();
1607 loop ())
1608 | OS.SysErr (s, _) =>
1609 (print ("System error: " ^ s ^ "\n");
1610 OpenSSL.close bio
1611 handle OpenSSL.OpenSSL _ => ();
1612 loop ())
1613 | IO.Io {name, function, cause} =>
1614 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1615 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1616 OpenSSL.close bio
1617 handle OpenSSL.OpenSSL _ => ();
1618 loop ())
1619 | OS.Path.InvalidArc =>
1620 (print "Invalid arc\n";
1621 OpenSSL.close bio
1622 handle OpenSSL.OpenSSL _ => ();
1623 loop ())
1624 | e =>
1625 (print "Unknown exception in main loop!\n";
1626 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1627 OpenSSL.close bio
1628 handle OpenSSL.OpenSSL _ => ();
1629 loop ()))
1630 handle e as (OpenSSL.OpenSSL s) =>
1631 (print ("OpenSSL error: " ^ s ^ "\n");
1632 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1633 loop ())
1634 | OS.SysErr (s, _) =>
1635 (print ("System error: " ^ s ^ "\n");
1636 loop ())
1637 | IO.Io {name, function, cause} =>
1638 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1639 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1640 loop ())
1641 | e =>
1642 (print "Unknown exception in main loop!\n";
1643 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1644 loop ())
1645 in
1646 print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
1647 print "Listening for connections....\n";
1648 loop ();
1649 OpenSSL.shutdown sock
1650 end
1651
1652 fun slave () =
1653 let
1654 val host = Slave.hostname ()
1655
1656 val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1657 Config.keyDir ^ "/" ^ host ^ "/key.pem",
1658 Config.trustStore)
1659
1660 val sock = OpenSSL.listen (context, Config.slavePort)
1661
1662 val _ = print ("Slave server starting at " ^ now () ^ "\n")
1663
1664 fun loop () =
1665 (case OpenSSL.accept sock of
1666 NONE => ()
1667 | SOME bio =>
1668 let
1669 val peer = OpenSSL.peerCN bio
1670 val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
1671 in
1672 if peer = Config.dispatcherName then let
1673 fun loop' files =
1674 case Msg.recv bio of
1675 NONE => print "Dispatcher closed connection unexpectedly\n"
1676 | SOME m =>
1677 case m of
1678 MsgFile file => loop' (file :: files)
1679 | MsgDoFiles => (Slave.handleChanges files;
1680 Msg.send (bio, MsgOk))
1681 | MsgRegenerate => (Domain.resetLocal ();
1682 Msg.send (bio, MsgOk))
1683 | MsgVmailChanged => (if Vmail.doChanged () then
1684 Msg.send (bio, MsgOk)
1685 else
1686 Msg.send (bio, MsgError "userdb update failed"))
1687 | _ => (print "Dispatcher sent unexpected command\n";
1688 Msg.send (bio, MsgError "Unexpected command"))
1689 in
1690 loop' [];
1691 ignore (OpenSSL.readChar bio);
1692 OpenSSL.close bio;
1693 loop ()
1694 end
1695 else if peer = "domtool" then
1696 case Msg.recv bio of
1697 SOME MsgShutdown => (OpenSSL.close bio;
1698 print ("Shutting down at " ^ now () ^ "\n\n"))
1699 | _ => (OpenSSL.close bio;
1700 loop ())
1701 else
1702 let
1703 val doIt = doIt' loop bio
1704 val user = peer
1705 in
1706 case Msg.recv bio of
1707 NONE => (OpenSSL.close bio
1708 handle OpenSSL.OpenSSL _ => ();
1709 loop ())
1710 | SOME m =>
1711 case m of
1712 (MsgQuery q) => (print (describeQuery q ^ "\n");
1713 Msg.send (bio, answerQuery q);
1714 ignore (OpenSSL.readChar bio);
1715 OpenSSL.close bio;
1716 loop ())
1717 | MsgCreateDbUser {dbtype, passwd} =>
1718 doIt (fn () =>
1719 case Dbms.lookup dbtype of
1720 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
1721 SOME ("Unknown database type " ^ dbtype))
1722 | SOME handler =>
1723 case #adduser handler {user = user, passwd = passwd} of
1724 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
1725 NONE)
1726 | SOME msg =>
1727 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
1728 SOME ("Error adding user: " ^ msg)))
1729 (fn () => ())
1730
1731 | MsgDbPasswd {dbtype, passwd} =>
1732 doIt (fn () =>
1733 case Dbms.lookup dbtype of
1734 NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
1735 SOME ("Unknown database type " ^ dbtype))
1736 | SOME handler =>
1737 case #passwd handler {user = user, passwd = passwd} of
1738 NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1739 NONE)
1740 | SOME msg =>
1741 ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1742 SOME ("Error adding user: " ^ msg)))
1743 (fn () => ())
1744
1745 | MsgCreateDb {dbtype, dbname, encoding} =>
1746 doIt (fn () =>
1747 if Dbms.validDbname dbname then
1748 case Dbms.lookup dbtype of
1749 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1750 SOME ("Unknown database type " ^ dbtype))
1751 | SOME handler =>
1752 if not (Dbms.validEncoding encoding) then
1753 ("Invalid encoding " ^ valOf encoding ^ " requested for database creation.",
1754 SOME "Invalid encoding")
1755 else
1756 case #createdb handler {user = user, dbname = dbname, encoding = encoding} of
1757 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1758 NONE)
1759 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1760 SOME ("Error creating database: " ^ msg))
1761 else
1762 ("Invalid database name " ^ user ^ "_" ^ dbname,
1763 SOME ("Invalid database name " ^ dbname)))
1764 (fn () => ())
1765
1766 | MsgDropDb {dbtype, dbname} =>
1767 doIt (fn () =>
1768 if Dbms.validDbname dbname then
1769 case Dbms.lookup dbtype of
1770 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1771 SOME ("Unknown database type " ^ dbtype))
1772 | SOME handler =>
1773 case #dropdb handler {user = user, dbname = dbname} of
1774 NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
1775 NONE)
1776 | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1777 SOME ("Error dropping database: " ^ msg))
1778 else
1779 ("Invalid database name " ^ user ^ "_" ^ dbname,
1780 SOME ("Invalid database name " ^ dbname)))
1781 (fn () => ())
1782
1783 | MsgGrantDb {dbtype, dbname} =>
1784 doIt (fn () =>
1785 if Dbms.validDbname dbname then
1786 case Dbms.lookup dbtype of
1787 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1788 SOME ("Unknown database type " ^ dbtype))
1789 | SOME handler =>
1790 case #grant handler {user = user, dbname = dbname} of
1791 NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
1792 NONE)
1793 | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1794 SOME ("Error granting permissions to database: " ^ msg))
1795 else
1796 ("Invalid database name " ^ user ^ "_" ^ dbname,
1797 SOME ("Invalid database name " ^ dbname)))
1798 (fn () => ())
1799 | MsgMysqlFixperms =>
1800 (print "Starting mysql-fixperms\n";
1801 doIt (fn () => if OS.Process.isSuccess
1802 (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
1803 ("Requested mysql-fixperms",
1804 NONE)
1805 else
1806 ("Requested mysql-fixperms, but execution failed!",
1807 SOME "Script execution failed."))
1808 (fn () => ()))
1809 | MsgFirewallRegen =>
1810 doIt (fn () => (Acl.read Config.aclFile;
1811 if Acl.query {user = user, class = "priv", value = "all"} then
1812 if List.exists (fn x => x = host) Config.Firewall.firewallNodes then
1813 if (Firewall.generateFirewallConfig (Firewall.parseRules ()) andalso Firewall.publishConfig ())
1814 then
1815 ("Firewall rules regenerated.", NONE)
1816 else
1817 ("Rules regeneration failed!", SOME "Script execution failed.")
1818 else ("Node not controlled by domtool firewall.", SOME (host))
1819 else
1820 ("Not authorized to regenerate firewall.", SOME ("Unauthorized user " ^ user ^ " attempted to regenerated firewall"))))
1821 (fn () => ())
1822
1823 | _ => (OpenSSL.close bio;
1824 loop ())
1825 end
1826 end handle OpenSSL.OpenSSL s =>
1827 (print ("OpenSSL error: " ^ s ^ "\n");
1828 OpenSSL.close bio
1829 handle OpenSSL.OpenSSL _ => ();
1830 loop ())
1831 | e as OS.SysErr (s, _) =>
1832 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1833 print ("System error: "^ s ^ "\n");
1834 OpenSSL.close bio
1835 handle OpenSSL.OpenSSL _ => ();
1836 loop ())
1837 | IO.Io {function, name, ...} =>
1838 (print ("IO error: " ^ function ^ ": " ^ name ^ "\n");
1839 OpenSSL.close bio
1840 handle OpenSSL.OpenSSL _ => ();
1841 loop ())
1842 | e =>
1843 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1844 print "Uncaught exception!\n";
1845 OpenSSL.close bio
1846 handle OpenSSL.OpenSSL _ => ();
1847 loop ()))
1848 handle OpenSSL.OpenSSL s =>
1849 (print ("OpenSSL error: " ^ s ^ "\n");
1850 loop ())
1851 | e =>
1852 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1853 print "Uncaught exception!\n";
1854 loop ())
1855 in
1856 loop ();
1857 OpenSSL.shutdown sock
1858 end
1859
1860 fun listBasis () =
1861 let
1862 val dir = Posix.FileSys.opendir Config.libRoot
1863
1864 fun loop files =
1865 case Posix.FileSys.readdir dir of
1866 NONE => (Posix.FileSys.closedir dir;
1867 files)
1868 | SOME fname =>
1869 if String.isSuffix ".dtl" fname then
1870 loop (OS.Path.joinDirFile {dir = Config.libRoot,
1871 file = fname}
1872 :: files)
1873 else
1874 loop files
1875 in
1876 loop []
1877 end
1878
1879 fun autodocBasis outdir =
1880 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1881
1882 end