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