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