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