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